Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Leeky effects #145

Open
wants to merge 7 commits into
base: main
Choose a base branch
from
+112 −106
Open

Leeky effects #145

Show file tree
Hide file tree
Changes from 5 commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
033d54a
Clear up monad throw uses
The1Penguin Nov 1, 2024
cc2f40a
Fetching part now is in effectful
The1Penguin Nov 2, 2024
04b9f68
Cursed be it here
The1Penguin Nov 2, 2024
019b3bc
imports sorted and displayed
The1Penguin Nov 2, 2024
5737640
update dependencies
The1Penguin Nov 2, 2024
79b7b22
Static >= Dynamic
The1Penguin Nov 2, 2024
c59e485
hehehehehehe
The1Penguin Nov 4, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
69 changes: 35 additions & 34 deletions app/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,28 +4,33 @@ module Main
( main
) where

import Control.Concurrent ( MVar
, newEmptyMVar
, threadDelay
, tryPutMVar
)
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 Control.Monad.Trans ( liftIO )
import Log.Backend.StandardOutput ( withStdOutLogger )
import Data.FileEmbed ( embedDir )
import Data.Foldable ( traverse_ )
import Data.IORef ( IORef
, readIORef
)
import Data.Time.Format ( defaultTimeLocale
, formatTime
import Effectful ( IOE
, (:>)
, Eff
, MonadIO(liftIO)
, runEff )
import Effectful.Concurrent ( Concurrent
, runConcurrent
, threadDelay
)
import Effectful.Concurrent.Async ( mapConcurrently_ )
import Effectful.Concurrent.MVar ( MVar
, newEmptyMVar
, tryPutMVar
)
import Effectful.FileSystem ( runFileSystem
, createDirectoryIfMissing
)
import Effectful.Log ( runLog
, defaultLogLevel
)
import Effectful.Reader.Dynamic ( runReader )
import Lens.Micro.Platform ( set
, view
)
Expand All @@ -38,9 +43,7 @@ import System.Console.GetOpt ( ArgDescr(..)
, getOpt
, usageInfo
)
import System.Directory ( createDirectoryIfMissing )
import System.Environment ( getArgs )
import System.IO ( stdout )
import Data.Text.Lazy.Encoding ( encodeUtf8 )
import Web.Twain ( get
, html
Expand Down Expand Up @@ -73,7 +76,7 @@ main = (recreateConfig . getOpt Permute opts <$> getArgs) >>= \case
(_ , _ , _ : _) -> usage
(_ , _ : _, _ ) -> usage
(Config { _cHelp = True }, _ , _ ) -> usage
(config , _ , _ ) -> do
(config , _ , _ ) -> runEff . runFileSystem . runConcurrent $ do
upd <- newEmptyMVar -- putMVar when to update
viewRef <- createViewReference
createDirectoryIfMissing True (_cLogPath config)
Expand All @@ -82,8 +85,7 @@ main = (recreateConfig . getOpt Permute opts <$> getArgs) >>= \case
-- 1. Timer that sends a signal to the updater when it's time to update
-- 2. Webserver that serves the menus to the user
-- 3. Updater that fetches new data from the restaurants
Async.runConcurrently $ traverse_
Async.Concurrently
mapConcurrently_ id
[ timer upd config
, webserver config viewRef upd
, updater upd viewRef config
Expand All @@ -93,25 +95,24 @@ 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 .
runReader cfg .
withStdOutLogger $ \logger ->
runLog "main" logger defaultLogLevel
(refresh viewRef upd)

webserver
:: Config
:: ( IOE :> es
, Concurrent :> es
)
=> Config
-> IORef View -- ^ View model
-> MVar () -- ^ Update signal
-> IO ()
-> Eff es ()
webserver Config{_cPort=webserverPort} viewRef upd =
run webserverPort $ foldr
liftIO . run webserverPort $ foldr
(logStdout . static $(embedDir "static") <$>)
(notFound (send $ html "not found..."))
[ get "/" (liftIO (readIORef viewRef) >>= send . html . encodeUtf8 . render)
, get "/r" (liftIO (tryPutMVar upd ()) >> send (redirect302 "/"))
, get "/r" (liftIO (runEff . runConcurrent $ tryPutMVar upd ()) >> send (redirect302 "/"))
]
Rembane marked this conversation as resolved.
Show resolved Hide resolved
17 changes: 5 additions & 12 deletions mat-chalmers.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -31,17 +31,13 @@ library
, attoparsec >= 0.14.4 && < 0.15
, 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
, old-locale == 1.0.0.7
, prettyprinter == 1.7.1
, wreq >= 0.5.4.2 && < 1.0.0.0
, retry == 0.9.3.1
, safe >= 0.3.21 && < 0.4
, tagsoup == 0.14.8
, text >= 2.0 && <= 3.0
Expand All @@ -50,7 +46,6 @@ library
, word8 == 0.1.3
, extra >= 1.7.16 && <= 1.8
, vector-space >= 0.16 && <0.18
, directory >= 1.3.5.0 && < 1.4

executable mat-chalmers
main-is: Main.hs
Expand All @@ -59,18 +54,16 @@ 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
, time >= 1.12.2 && < 1.13
, twain >= 2.1.2.0 && < 3.0.0.0
, wai-extra >= 3.1.14 && < 4.0
, wai-middleware-static-embedded == 0.1.0.0
, directory >= 1.3.5.0 && < 1.4
, warp >= 3.4.0 && < 4.0.0
, async >= 2.2.5 && <= 3.0
default-language: GHC2021
Expand Down
75 changes: 37 additions & 38 deletions src/Model.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -12,31 +12,19 @@ import Control.Concurrent.MVar ( MVar
, takeMVar
)
import Control.Monad ( filterM )
import Control.Monad.Catch ( MonadThrow )
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 Prettyprinter ( prettyList
, (<+>)
)
import Data.AffineSpace ( (.+^)
, (.-^)
)
import Data.Text ( pack )
import Data.Thyme ( _localDay
, _localTimeOfDay
, _todHour
Expand All @@ -46,14 +34,26 @@ import Data.Thyme ( _localDay
, _utctDay
)
import Data.Thyme.Time ( toThyme )
import Effectful ( IOE
, (:>)
, Eff
, MonadIO(..)
)
import Effectful.FileSystem ( FileSystem
, getAccessTime
, listDirectory
, removeFile )
import Effectful.Log ( Log
, logInfo_
)
import Effectful.Reader.Dynamic ( Reader
, asks
)
import Lens.Micro.Platform ( (^.)
, (&)
, (%~)
, view
)
import System.Directory ( listDirectory
, getAccessTime
, removeFile )
import Text.Printf ( printf )

import Config
Expand All @@ -67,16 +67,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
, MonadThrow 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 @@ -86,30 +85,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
, MonadThrow 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
22 changes: 13 additions & 9 deletions src/Model/Karen.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,8 +8,6 @@ module Model.Karen
where

import Control.Monad ( (>=>), filterM )
import Control.Monad.Catch ( MonadThrow )
import Control.Monad.IO.Class ( MonadIO (liftIO) )
import Data.Aeson ( object
, (.=)
, (.:)
Expand All @@ -29,6 +27,11 @@ import Data.Text.Lazy ( Text
import Data.Thyme.Calendar ( Day
, showGregorian
)
import Effectful ( IOE
, (:>)
, Eff
, MonadIO(liftIO)
)
import Network.Wreq ( asValue
, post
, responseBody )
Expand Down Expand Up @@ -73,13 +76,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 @@ -131,12 +135,12 @@ parse lang =

-- | Fetch a restaurant from Kåren's GraphQL API
fetchAndCreateRestaurant
:: (MonadIO m, MonadThrow 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 @@ -145,4 +149,4 @@ fetchAndCreateRestaurant day title tag uuid =
<> "/"
<> uuid
)
<$> fmap (parse "Swedish") (liftIO (fetch (unpack uuid) day))
<$> fmap (parse "Swedish") (fetch (unpack uuid) day)
Loading
Loading