Skip to content

Commit

Permalink
Fetching part now is in effectful
Browse files Browse the repository at this point in the history
  • Loading branch information
@The1Penguin
The1Penguin committed Nov 2, 2024
1 parent 033d54a commit cc2f40a
Show file tree
Hide file tree
Showing 6 changed files with 61 additions and 75 deletions.
31 changes: 12 additions & 19 deletions app/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,21 +11,16 @@ import Control.Concurrent ( MVar
)
import qualified Control.Concurrent.Async as Async
import Control.Monad ( forever )
import Control.Monad.Log ( defaultBatchingOptions
, renderWithTimestamp
, runLoggingT
, withFDHandler
)
import Control.Monad.Reader ( runReaderT )
import Effectful ( runEff )
import Effectful.Reader.Dynamic ( runReader )
import Effectful.Log ( runLog, defaultLogLevel )
import Log.Backend.StandardOutput ( withStdOutLogger )
import Control.Monad.Trans ( liftIO )
import Data.FileEmbed ( embedDir )
import Data.Foldable ( traverse_ )
import Data.IORef ( IORef
, readIORef
)
import Data.Time.Format ( defaultTimeLocale
, formatTime
)
import Lens.Micro.Platform ( set
, view
)
Expand All @@ -40,7 +35,6 @@ import System.Console.GetOpt ( ArgDescr(..)
)
import System.Directory ( createDirectoryIfMissing )
import System.Environment ( getArgs )
import System.IO ( stdout )
import Data.Text.Lazy.Encoding ( encodeUtf8 )
import Web.Twain ( get
, html
Expand All @@ -52,6 +46,7 @@ import Web.Twain ( get
import Config
import Model
import View ( render )
import Effectful.FileSystem (runFileSystem)

opts :: [OptDescr (Config -> Config)]
opts =
Expand Down Expand Up @@ -93,15 +88,13 @@ main = (recreateConfig . getOpt Permute opts <$> getArgs) >>= \case
forever $ tryPutMVar upd () >> threadDelay (view cInterval cfg)

updater upd viewRef cfg =
forever
$ withFDHandler defaultBatchingOptions stdout 1.0 80
$ \logCallback -> runLoggingT
(runReaderT (refresh viewRef upd) cfg)
( logCallback
. renderWithTimestamp
(formatTime defaultTimeLocale "T%H:%M:%S")
id
)
forever .
runEff .
runReader cfg .
runFileSystem .
withStdOutLogger $ \logger ->
runLog "main" logger defaultLogLevel
(refresh viewRef upd)

webserver
:: Config
Expand Down
9 changes: 5 additions & 4 deletions mat-chalmers.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,9 +32,9 @@ library
, base >=4.18.2.0 && < 5.0
, bytestring >=0.11 && < 0.12
, css-text >= 0.1.3.0 && < 0.2
, exceptions >= 0.10.5 && < 0.11.0
, effectful >= 2.4.0.0 && < 3.0.0.0
, log-effectful >= 1.0.0.0 && < 2.0.0.0
, heredoc >= 0.2.0.0 && < 0.3
, logging-effect >= 1.4.0 && <= 2.0
, microlens-platform >= 0.4.3.5 && < 0.5
, lucid >= 2.11.1 && < 3
, mtl >= 2.3.1 && < 2.5
Expand All @@ -59,10 +59,11 @@ executable mat-chalmers
build-depends: mat-chalmers
, base
, bytestring
, exceptions
, effectful >= 2.4.0.0 && < 3.0.0.0
, log-effectful >= 1.0.0.0 && < 2.0.0.0
, log-base >= 0.12.0.0 && < 1.0.0.0
, file-embed
, microlens-platform
, logging-effect
, mtl
, prettyprinter
, text
Expand Down
61 changes: 26 additions & 35 deletions src/Model.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,30 +12,23 @@ import Control.Concurrent.MVar ( MVar
, takeMVar
)
import Control.Monad ( filterM )
import Control.Monad.IO.Class ( MonadIO
, liftIO
)
import Control.Monad.Log ( MonadLog
, WithTimestamp
, logMessage
, timestamp
)
import Control.Monad.Reader ( MonadReader
, asks
)
import Data.IORef ( IORef
, newIORef
, writeIORef
)
import Data.Foldable ( for_ )
import Data.Functor ( (<&>) )
import Prettyprinter ( Doc
, prettyList
import Effectful
import Effectful.FileSystem
import Effectful.Log
import Effectful.Reader.Dynamic
import Prettyprinter ( prettyList
, (<+>)
)
import Data.AffineSpace ( (.+^)
, (.-^)
)
import Data.Text ( pack )
import Data.Thyme ( _localDay
, _localTimeOfDay
, _todHour
Expand All @@ -50,9 +43,6 @@ import Lens.Micro.Platform ( (^.)
, (%~)
, view
)
import System.Directory ( listDirectory
, getAccessTime
, removeFile )
import Text.Printf ( printf )

import Config
Expand All @@ -66,15 +56,15 @@ import Model.Linsen
-- where the View model has all the current data. Call update signal to get
-- new data from the data sources.
refresh
:: ( Monad m
, MonadIO m
, MonadLog (WithTimestamp (Doc ann)) m
, MonadReader Config m
:: ( IOE :> es
, Reader Config :> es
, Log :> es
, FileSystem :> es
)
=> IORef View -> MVar () -> m ()
=> IORef View -> MVar () -> Eff es ()
refresh ref upd = do
liftIO $ takeMVar upd
logMessage =<< timestamp "Updating view..."
logInfo_ "Updating view..."
v <- update
liftIO $ writeIORef ref v

Expand All @@ -84,29 +74,30 @@ createViewReference = liftIO $ do
newIORef (View [] "" (now ^. _zonedTimeToLocalTime))

-- | Deletes logs in the logs folder that are older than `_cLogAge`
removeOldLogs :: ( MonadIO m
, MonadLog (WithTimestamp (Doc ann)) m
, MonadReader Config m
) => m ()
removeOldLogs :: ( IOE :> es
, Reader Config :> es
, FileSystem :> es
, Log :> es
) => Eff es ()
removeOldLogs = do
now <- liftIO getCurrentTime
offset <- asks _cLogAge
path <- asks _cLogPath
liftIO (listDirectory path) >>=
mapM (\s -> liftIO (getAccessTime s) <&> (s,)) . (((path ++ "/") ++) <$>) >>=
listDirectory path >>=
mapM (\s -> getAccessTime s <&> (s,)) . (((path ++ "/") ++) <$>) >>=
filterM (pure . (<= (now & _utctDay %~ (.-^ offset))) . toThyme . snd) <&>
(fst <$>) >>= \case
[] -> pure ()
files -> timestamp ("Removing the following files:" <+> prettyList files) >>=
logMessage >>
liftIO (mapM_ removeFile files)
files -> logInfo_ (pack . show $ "Removing the following files:" <+> prettyList files) >>
mapM_ removeFile files

update
:: ( MonadIO m
, MonadLog (WithTimestamp (Doc ann)) m
, MonadReader Config m
:: ( IOE :> es
, Reader Config :> es
, Log :> es
, FileSystem :> es
)
=> m View
=> Eff es View
update = do
nextDayHour <- asks _cNextDayHour
dateNow <- liftIO $ fmap (view _zonedTimeToLocalTime) getZonedTime
Expand Down
17 changes: 9 additions & 8 deletions src/Model/Karen.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@ module Model.Karen
where

import Control.Monad ( (>=>), filterM )
import Control.Monad.IO.Class ( MonadIO (liftIO) )
import Effectful
import Data.Aeson ( object
, (.=)
, (.:)
Expand Down Expand Up @@ -72,13 +72,14 @@ type Language = String

-- | Fetch a menu from Kårens GraphQL API.
fetch ::
String -- ^ RestaurantUUID
(IOE :> es)
=> String -- ^ RestaurantUUID
-> Day -- ^ Day
-> IO Value -- ^ A JSON response or horrible crash
-> Eff es Value -- ^ A JSON response or horrible crash
fetch restaurantUUID day =
post
liftIO (post
"https://plateimpact-heimdall.azurewebsites.net/graphql"
requestData >>= asValue >>= (^.^ responseBody)
requestData) >>= asValue >>= (^.^ responseBody)
where
requestData = object
[ "query" .= graphQLQuery
Expand Down Expand Up @@ -130,12 +131,12 @@ parse lang =

-- | Fetch a restaurant from Kåren's GraphQL API
fetchAndCreateRestaurant
:: (MonadIO m)
:: (IOE :> es)
=> Day -- ^ Day
-> Text -- ^ Title
-> Text -- ^ Tag
-> Text -- ^ RestaurantUUID
-> m Restaurant -- ^ Fetched Restaurant
-> Eff es Restaurant -- ^ Fetched Restaurant
fetchAndCreateRestaurant day title tag uuid =
Restaurant
title
Expand All @@ -144,4 +145,4 @@ fetchAndCreateRestaurant day title tag uuid =
<> "/"
<> uuid
)
<$> fmap (parse "Swedish") (liftIO (fetch (unpack uuid) day))
<$> fmap (parse "Swedish") (fetch (unpack uuid) day)
12 changes: 6 additions & 6 deletions src/Model/Linsen.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,7 @@ import Control.Monad ( (>=>)
, zipWithM
, filterM
, ap )
import Control.Monad.IO.Class ( MonadIO (liftIO) )
import Effectful
import Data.Aeson ( (.:)
, withObject
, Value )
Expand Down Expand Up @@ -81,9 +81,9 @@ pattern MeatDish = 2
pattern FishDish = 6
pattern VegDish = 10

fetch :: IO Value -- ^ A JSON response or horrible crash
fetch :: (IOE :> es) => Eff es Value -- ^ A JSON response or horrible crash
fetch =
get "https://cafe-linsen.se/api/menu" >>= asValue >>= (^.^ responseBody)
liftIO (get "https://cafe-linsen.se/api/menu") >>= asValue >>= (^.^ responseBody)

parse
:: Day -- ^ Day to parse
Expand Down Expand Up @@ -155,11 +155,11 @@ parse day =
<$> last vs .: "text"

fetchAndCreateLinsen
:: (MonadIO m)
:: (IOE :> es)
=> Day -- ^ Day
-> m Restaurant -- ^ Fetched Restaurant
-> Eff es Restaurant -- ^ Fetched Restaurant
fetchAndCreateLinsen day =
Restaurant
"Café Linsen"
"https://cafe-linsen.se/#menu"
<$> fmap (parse day) (liftIO fetch)
<$> fmap (parse day) fetch
6 changes: 3 additions & 3 deletions src/Model/Wijkanders.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@ import Control.Arrow ( (***)
, (>>>)
)
import Control.Monad ( (<=<) )
import Control.Monad.IO.Class ( MonadIO (liftIO) )
import Effectful
import Data.Attoparsec.ByteString.Lazy ( maybeResult
, parse
, skip
Expand Down Expand Up @@ -122,9 +122,9 @@ getWijkanders d b = go b
xs -> Right xs

fetchAndCreateWijkanders
:: (MonadIO m)
:: (IOE :> es)
=> Day
-> m Restaurant
-> Eff es Restaurant
fetchAndCreateWijkanders day =
liftIO (get wijkandersAPIURL) >>= (^.^ responseBody) <&>
Restaurant "Wijkanders" (pack wijkandersAPIURL) . getWijkanders day

1 comment on commit cc2f40a

@Rembane
Copy link
Contributor

@Rembane Rembane commented on cc2f40a Nov 2, 2024

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

effectful makes for pretty code! Keep up the good work! 😸

Please sign in to comment.