fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Setup hlint & yesod

Browse Source
This commit is contained in:
Gregor Kleen 2018-10-31 23:55:29 +01:00
parent f056f0373b
commit 3d91e0fabd
19 changed files with 405 additions and 358 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
hlint/Hlint.hs Normal file
View File

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hlint-test -optF --git -optF -j -optF src #-}

2
models
View File

@ -11,7 +11,7 @@ User json
dateFormat DateTimeFormat "default='%d.%m.%Y'"
timeFormat DateTimeFormat "default='%R'"
downloadFiles Bool default=false
mailLanguages MailLanguages "default='[]'"
mailLanguages MailLanguages default='[]'
notificationSettings NotificationSettings
UniqueAuthentication ident
UniqueEmail email

260
package.yaml
View File

@ -2,114 +2,111 @@ name: uniworx
version: "0.0.0"
dependencies:
# Due to a bug in GHC 8.0.1, we block its usage
# See: https://ghc.haskell.org/trac/ghc/ticket/12130
- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
# version 1.0 had a bug in reexporting Handler, causing trouble
- classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
- foreign-store
- yesod >=1.4.3 && <1.5
- yesod-core >=1.4.30 && <1.5
- yesod-auth >=1.4.0 && <1.5
- yesod-static >=1.4.0.3 && <1.6
- yesod-form >=1.4.0 && <1.5
- classy-prelude >=0.10.2
- classy-prelude-conduit >=0.10.2
- bytestring >=0.9 && <0.11
- text >=0.11 && <2.0
- persistent >=2.7.2 && <2.8
- persistent-postgresql >=2.1.1 && <2.8
- persistent-template >=2.0 && <2.8
- template-haskell
- shakespeare >=2.0 && <2.1
- hjsmin >=0.1 && <0.3
- monad-control >=0.3 && <1.1
- wai-extra >=3.0 && <3.1
- yaml >=0.8 && <0.9
- http-conduit >=2.1 && <2.3
- directory >=1.1 && <1.4
- warp >=3.0 && <3.3
- data-default
- aeson >=0.6 && <1.3
- conduit >=1.0 && <2.0
- monad-logger >=0.3 && <0.4
- fast-logger >=2.2 && <2.5
- wai-logger >=2.2 && <2.4
- file-embed
- safe
- unordered-containers
- containers
- vector
- time
- case-insensitive
- wai
- cryptonite
- cryptonite-conduit
- saltine
- base64-bytestring
- memory
- http-api-data
- profunctors
- colonnade >=1.1.1
- yesod-colonnade >=1.1.0
- blaze-markup
- zip-stream
- filepath
- transformers
- wl-pprint-text
- uuid-types
- path-pieces
- uuid-crypto
- filepath-crypto
- cryptoids-types
- cryptoids
- cryptoids-class
- binary
- cereal
- mtl
- sandi
- esqueleto
- mime-types
- generic-deriving
- blaze-html
- conduit-resumablesink >=0.2
- parsec
- uuid
- exceptions
- stm
- stm-chans
- stm-conduit
- lens
- MonadRandom
- email-validate
- scientific
- tz
- system-locale
- th-lift-instances
- gitrev
- Glob
- ldap-client
- connection
- universe
- universe-base
- random
- random-shuffle
- th-abstraction
- HaskellNet
- HaskellNet-SSL
- network
- resource-pool
- mime-mail
- hashable
- aeson-pretty
- resourcet
- postgresql-simple
- word24
- mmorph
- clientsession
# Due to a bug in GHC 8.0.1, we block its usage
# See: https://ghc.haskell.org/trac/ghc/ticket/12130
- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
# version 1.0 had a bug in reexporting Handler, causing trouble
- classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
- foreign-store
- yesod >=1.4.3 && <1.5
- yesod-core >=1.4.30 && <1.5
- yesod-auth >=1.4.0 && <1.5
- yesod-static >=1.4.0.3 && <1.6
- yesod-form >=1.4.0 && <1.5
- classy-prelude >=0.10.2
- classy-prelude-conduit >=0.10.2
- bytestring >=0.9 && <0.11
- text >=0.11 && <2.0
- persistent >=2.7.2 && <2.8
- persistent-postgresql >=2.1.1 && <2.8
- persistent-template >=2.0 && <2.8
- template-haskell
- shakespeare >=2.0 && <2.1
- hjsmin >=0.1 && <0.3
- monad-control >=0.3 && <1.1
- wai-extra >=3.0 && <3.1
- yaml >=0.8 && <0.9
- http-conduit >=2.1 && <2.3
- directory >=1.1 && <1.4
- warp >=3.0 && <3.3
- data-default
- aeson >=0.6 && <1.3
- conduit >=1.0 && <2.0
- monad-logger >=0.3 && <0.4
- fast-logger >=2.2 && <2.5
- wai-logger >=2.2 && <2.4
- file-embed
- safe
- unordered-containers
- containers
- vector
- time
- case-insensitive
- wai
- cryptonite
- cryptonite-conduit
- saltine
- base64-bytestring
- memory
- http-api-data
- profunctors
- colonnade >=1.1.1
- yesod-colonnade >=1.1.0
- blaze-markup
- zip-stream
- filepath
- transformers
- wl-pprint-text
- uuid-types
- path-pieces
- uuid-crypto
- filepath-crypto
- cryptoids-types
- cryptoids
- cryptoids-class
- binary
- cereal
- mtl
- sandi
- esqueleto
- mime-types
- generic-deriving
- blaze-html
- conduit-resumablesink >=0.2
- parsec
- uuid
- exceptions
- stm
- stm-chans
- stm-conduit
- lens
- MonadRandom
- email-validate
- scientific
- tz
- system-locale
- th-lift-instances
- gitrev
- Glob
- ldap-client
- connection
- universe
- universe-base
- random
- random-shuffle
- th-abstraction
- HaskellNet
- HaskellNet-SSL
- network
- resource-pool
- mime-mail
- hashable
- aeson-pretty
- resourcet
- postgresql-simple
- word24
- mmorph
- clientsession
other-extensions:
- GeneralizedNewtypeDeriving
@ -159,6 +156,10 @@ default-extensions:
- BinaryLiterals
- PolyKinds
ghc-options:
- -Wall
- -fwarn-tabs
# The library contains all of our application code. The executable
# defined below is just a thin wrapper.
library:
@ -167,16 +168,12 @@ library:
- condition: (flag(dev)) || (flag(library-only))
then:
ghc-options:
- -Wall
- -fwarn-tabs
- -O0
- -ddump-splices
- -O0
- -ddump-splices
cpp-options: -DDEVELOPMENT
else:
ghc-options:
- -Wall
- -fwarn-tabs
- -O2
- -O2
# Runnable executable for our application
executables:
@ -184,28 +181,33 @@ executables:
main: main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- uniworx
- uniworx
when:
- condition: flag(library-only)
buildable: false
- condition: flag(library-only)
buildable: false
# Test suite
tests:
test:
yesod:
main: Spec.hs
source-dirs: test
ghc-options: -Wall
dependencies:
- uniworx
- hspec >=2.0.0
- QuickCheck
- yesod-test
- conduit-extra
- quickcheck-instances
- uniworx
- hspec >=2.0.0
- QuickCheck
- yesod-test
- conduit-extra
- quickcheck-instances
hlint:
main: Hlint.hs
other-modules: []
source-dirs: hlint
dependencies:
- hlint-test
# Define flags used by "yesod devel" to make compilation faster
flags:

17
src/Application.hs
View File

@ -30,9 +30,11 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
OutputFormat (..), destination,
mkRequestLogger, outputFormat)
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
import System.Log.FastLogger (defaultBufSize, newStderrLoggerSet,
toLogStr)
import qualified Data.Map.Strict as Map
import Foreign.Store
import qualified Data.UUID as UUID
@ -100,16 +102,14 @@ makeFoundation appSettings@(AppSettings{..}) = do
appHttpManager <- newManager
appLogger <- liftIO $ do
tgetter <- newTimeCache "%Y-%m-%d %T %z"
loggerSet <- newStdoutLoggerSet defaultBufSize
loggerSet <- newStderrLoggerSet defaultBufSize
return $ Yesod.Logger loggerSet tgetter
appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID
(appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do
chan <- newBroadcastTMChan
recvChan <- dupTMChan chan
return (chan, recvChan)
appJobCtl <- liftIO $ newTVarIO Map.empty
appCronThread <- liftIO newEmptyTMVarIO
appLogSettings <- liftIO $ newTVarIO appInitialLogSettings
@ -149,7 +149,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appErrorMsgKey
handleJobs recvChans foundation
handleJobs foundation
-- Return the foundation
return foundation
@ -322,8 +322,7 @@ getApplicationRepl = do
return (getPort wsettings, foundation, app1)
shutdownApp :: MonadIO m => UniWorX -> m ()
shutdownApp UniWorX{..} = do
liftIO . atomically $ mapM_ closeTMChan appJobCtl
shutdownApp = stopJobCtl
---------------------------------------------

3
src/Foundation.hs
View File

@ -118,7 +118,8 @@ data UniWorX = UniWorX
, appLogSettings :: TVar LogSettings
, appCryptoIDKey :: CryptoIDKey
, appInstanceID :: InstanceId
, appJobCtl :: [TMChan JobCtl]
, appJobCtl :: TVar (Map ThreadId (TMChan JobCtl))
, appCronThread :: TMVar (ReleaseKey, ThreadId)
, appErrorMsgKey :: SecretBox.Key
, appSessionKey :: ClientSession.Key
}

2
src/Import/NoFoundation.hs
View File

@ -40,6 +40,8 @@ import Data.List.NonEmpty as Import (NonEmpty(..))
import Control.Monad.Morph as Import (MFunctor(..))
import Control.Monad.Trans.Resource as Import (ReleaseKey)
import Control.Monad.Trans.RWS (RWST)

256
src/Jobs.hs
View File

@ -2,6 +2,7 @@ module Jobs
( module Types
, module Jobs.Queue
, handleJobs
, stopJobCtl
) where
import Import
@ -25,7 +26,7 @@ import Data.Semigroup (Max(..))
import Utils.Sql
import Control.Monad.Random (evalRand, mkStdGen)
import Control.Monad.Random (evalRand, mkStdGen, getRandomR)
import Cron
import qualified Data.HashMap.Strict as HashMap
@ -33,18 +34,19 @@ import Data.HashMap.Strict (HashMap)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Foldable (foldrM)
import Control.Monad.Trans.Reader (mapReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, mapStateT)
import qualified Control.Monad.State.Class as State
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate)
import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate, release)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Logger
import Control.Monad.Random (MonadRandom(..), evalRand)
import Data.Time.Clock
import Data.Time.Zones
@ -66,131 +68,171 @@ data JobQueueException = JInvalid QueuedJobId QueuedJob
instance Exception JobQueueException
handleJobs :: (MonadResource m, MonadIO m) => [TMChan JobCtl] -> UniWorX -> m ()
-- | Read control commands from `appJobCtl` and address them as they come in
handleJobs :: ( MonadResource m
, MonadIO m
)
=> UniWorX -> m ()
-- | Spawn a set of workers that read control commands from `appJobCtl` and address them as they come in
--
-- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders.
-- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
handleJobs recvChans foundation@UniWorX{..} = do
jobCrontab <- liftIO $ newTVarIO HashMap.empty
handleJobs foundation@UniWorX{..} = do
let num = appJobWorkers appSettings
jobCrontab <- liftIO $ newTMVarIO HashMap.empty
jobConfirm <- liftIO $ newTVarIO HashMap.empty
forM_ (zip [1..] recvChans) $ \(n, chan) ->
forM_ [1..num] $ \n -> do
(bChan, chan) <- atomically $ newBroadcastTMChan >>= (\c -> (c, ) <$> dupTMChan c)
let
logStart = $logDebugS ("Jobs #" <> tshow n) "Starting"
logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping"
doFork = fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n
in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
removeChan = atomically . modifyTVar' appJobCtl . Map.delete =<< myThreadId
doFork = flip forkFinally (\_ -> removeChan) . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n
(_, tId) <- allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
atomically . modifyTVar' appJobCtl $ Map.insert tId bChan
-- Start cron operation
void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread)
liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
writeJobCtlBlock JobCtlDetermineCrontab
registeredCron <- liftIO newEmptyTMVarIO
let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
unsafeHandler foundation $ runReaderT execCrontab JobContext{..}
unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread
cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab)
registeredCron' <- atomically $ do
registeredCron' <- tryPutTMVar appCronThread cData
registeredCron' <$ putTMVar registeredCron registeredCron'
when registeredCron' $
liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
writeJobCtlBlock JobCtlDetermineCrontab
stopJobCtl :: MonadIO m => UniWorX -> m ()
-- ^ Stop all worker threads currently running
stopJobCtl UniWorX{appJobCtl, appCronThread} = do
mcData <- atomically $ tryReadTMVar appCronThread
whenIsJust mcData $ \(rKey, _) -> do
liftIO $ release rKey
atomically . guardM $ isEmptyTMVar appCronThread
wMap <- liftIO $ readTVarIO appJobCtl
atomically $ forM_ wMap closeTMChan
atomically $ do
wMap' <- readTVar appJobCtl
guard . none (`Map.member` wMap') $ Map.keysSet wMap
execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) ()
-- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
-- seen, wait for the time of the next job and fire it
execCrontab = flip evalStateT HashMap.empty . forever $ do
mapStateT (liftHandlerT . runDB . setSerializable) $ do
let
merge (Entity leId CronLastExec{..})
| Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
= State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
| otherwise = lift $ delete leId
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
now <- liftIO getCurrentTime
(currentCrontab, (jobCtl, nextMatch)) <- mapStateT (mapReaderT $ liftIO . atomically) $ do
crontab <- liftBase . readTVar =<< asks jobCrontab
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
prevExec <- State.get
case earliestJob prevExec crontab now of
Nothing -> liftBase retry
Just (_, MatchNone) -> liftBase retry
Just x -> return (crontab, x)
let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
newCrontab <- lift . lift . hoist lift $ determineCrontab'
if
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-> do
now <- liftIO $ getCurrentTime
instanceID <- getsYesod appInstanceID
State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
case jobCtl of
JobCtlQueue job -> do
lift . lift $ upsertBy
(UniqueCronLastExec $ toJSON job)
CronLastExec
{ cronLastExecJob = toJSON job
, cronLastExecTime = now
, cronLastExecInstance = instanceID
}
[ CronLastExecTime =. now ]
lift . lift $ queueDBJob job
other -> writeJobCtl other
| otherwise
-> lift . mapReaderT (liftIO . atomically) $
lift . flip writeTVar newCrontab =<< asks jobCrontab
case nextMatch of
MatchAsap -> doJob
MatchNone -> return ()
MatchAt nextTime -> do
JobContext{jobCrontab} <- ask
nextTime' <- applyJitter jobCtl nextTime
$logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
logFunc <- askLoggerIO
whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
doJob
execCrontab = evalStateT go HashMap.empty
where
acc :: NominalDiffTime
acc = 1e-3
go = do
mapStateT (liftHandlerT . runDB . setSerializable) $ do
let
merge (Entity leId CronLastExec{..})
| Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
= State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
| otherwise = lift $ delete leId
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
applyJitter seed t = do
appInstance <- getsYesod appInstanceID
let
halfRange = truncate $ 0.5 / acc
diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
return $ addUTCTime diff t
now <- liftIO getCurrentTime
currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
case crontab' of
Nothing -> return Nothing
Just crontab -> Just <$> do
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
prevExec <- State.get
case earliestJob prevExec crontab now of
Nothing -> liftBase retry
Just (_, MatchNone) -> liftBase retry
Just x -> return (crontab, x)
earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
earliestJob lastTimes crontab now = foldr go Nothing $ HashMap.toList crontab
case currentState of
Nothing -> return ()
Just (currentCrontab, (jobCtl, nextMatch)) -> do
let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
newCrontab <- lift . lift . hoist lift $ determineCrontab'
if
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-> do
now <- liftIO $ getCurrentTime
instanceID <- getsYesod appInstanceID
State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
case jobCtl of
JobCtlQueue job -> do
lift . lift $ upsertBy
(UniqueCronLastExec $ toJSON job)
CronLastExec
{ cronLastExecJob = toJSON job
, cronLastExecTime = now
, cronLastExecInstance = instanceID
}
[ CronLastExecTime =. now ]
lift . lift $ queueDBJob job
other -> writeJobCtl other
| otherwise
-> lift . mapReaderT (liftIO . atomically) $
lift . void . flip swapTMVar newCrontab =<< asks jobCrontab
case nextMatch of
MatchAsap -> doJob
MatchNone -> return ()
MatchAt nextTime -> do
JobContext{jobCrontab} <- ask
nextTime' <- applyJitter jobCtl nextTime
$logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
logFunc <- askLoggerIO
whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
doJob
go
where
go (jobCtl, cron) mbPrev
| Just (_, t') <- mbPrev
, t' < t
= mbPrev
| otherwise
= Just (jobCtl, t)
acc :: NominalDiffTime
acc = 1e-3
applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
applyJitter seed t = do
appInstance <- getsYesod appInstanceID
let
halfRange = truncate $ 0.5 / acc
diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
return $ addUTCTime diff t
earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
earliestJob lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
where
t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron
go' (jobCtl, cron) mbPrev
| Just (_, t') <- mbPrev
, t' < t
= mbPrev
| otherwise
= Just (jobCtl, t)
where
t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron
waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
waitUntil crontabTV crontab nextTime = runResourceT $ do
diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
waitTime'
| diffT < acc = "Done"
| otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
$logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
if
| diffT < acc -> return True
| otherwise -> do
retVar <- liftIO newEmptyTMVarIO
void $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread)
let
awaitDelayThread = False <$ takeTMVar retVar
awaitCrontabChange = do
crontab' <- readTVar crontabTV
True <$ guard (crontab /= crontab')
crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
waitUntil crontabTV crontab nextTime = runResourceT $ do
diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
waitTime'
| diffT < acc = "Done"
| otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
$logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
if
| diffT < acc -> return True
| otherwise -> do
retVar <- liftIO newEmptyTMVarIO
void . liftIO . forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar
let
awaitDelayThread = False <$ takeTMVar retVar
awaitCrontabChange = do
crontab' <- tryReadTMVar crontabTV
True <$ guard (Just crontab /= crontab')
crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
handleJobs' :: Int -> Sink JobCtl (ReaderT JobContext Handler) ()
handleJobs' :: Natural -> Sink JobCtl (ReaderT JobContext Handler) ()
handleJobs' wNum = C.mapM_ $ \jctl -> do
$logDebugS logIdent $ tshow jctl
resVars <- mapReaderT (liftIO . atomically) $
@ -228,7 +270,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
-- $logDebugS logIdent $ tshow newCTab
mapReaderT (liftIO . atomically) $
lift . flip writeTVar newCTab =<< asks jobCrontab
lift . void . flip swapTMVar newCTab =<< asks jobCrontab
jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
jLocked jId act = do

20
src/Jobs/Queue.hs
View File

@ -17,15 +17,26 @@ import Control.Monad.Trans.Reader (ReaderT, mapReaderT)
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen, uniform)
import Control.Monad.Random (evalRand, mkStdGen, uniform)
data JobQueueException = JobQueuePoolEmpty
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
instance Exception JobQueueException
writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
writeJobCtl cmd = do
tid <- liftIO myThreadId
chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl
liftIO . atomically $ writeTMChan chan cmd
wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO
if
| null wMap -> throwM JobQueuePoolEmpty
| otherwise -> do
let chan = flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) $ uniform wMap
liftIO . atomically $ writeTMChan chan cmd
writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
writeJobCtlBlock cmd = do
@ -72,6 +83,3 @@ runDBJobs act = do
(ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
forM_ jIds $ writeJobCtl . JobCtlPerform
return ret

2
src/Jobs/Types.hs
View File

@ -55,6 +55,6 @@ instance Hashable JobCtl
data JobContext = JobContext
{ jobCrontab :: TVar (Crontab JobCtl)
{ jobCrontab :: TMVar (Crontab JobCtl)
, jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException))))
}

40
src/Model/Migration.hs
View File

@ -75,15 +75,15 @@ migrateAll = do
Confusion about quotes, from the PostgreSQL Manual:
Single quotes for string constants, double quotes for table/column names.
QuasiQuoter: ^{TableName} @{ColumnName} (includes Escaping);
#{anything} (no escaping);
QuasiQuoter: ^{TableName} @{ColumnName} (escaped as column/table-name; value determined from current model);
#{anything} (escaped as value);
-}
customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
customMigrations = Map.fromListWith (>>)
[ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
, whenM (tableExists "user") $ do -- New theme format
, whenM (columnExists "user" "theme") $ do -- New theme format
userThemes <- [sqlQQ| SELECT "id", "theme" FROM "user"; |]
forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of
Just v
@ -98,7 +98,7 @@ customMigrations = Map.fromListWith (>>)
|]
)
, ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|]
, whenM (tableExists "school") $ do -- SchoolId is the Shorthand CI Text now
, whenM (columnExists "school" "id") $ do -- SchoolId is the Shorthand CI Text now
-- Read old table into memory
schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |]
let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed
@ -143,9 +143,9 @@ customMigrations = Map.fromListWith (>>)
FOREIGN KEY (school) REFERENCES school(shorthand);
|]
[executeQQ|
ALTER TABLE "school" DROP COLUMN "id";
ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
|]
ALTER TABLE "school" DROP COLUMN "id";
ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
|]
)
, ( AppliedMigrationKey [migrationVersion|2.0.0|] [version|3.0.0|]
, whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now.
@ -161,7 +161,7 @@ customMigrations = Map.fromListWith (>>)
, whenM (tableExists "user") $ do
userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
[executeQQ|
ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT '';
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "surname" text DEFAULT '';
|]
forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
Just name -> update uid [UserSurname =. name]
@ -170,23 +170,22 @@ customMigrations = Map.fromListWith (>>)
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
, whenM (tableExists "sheet") $ do
[executeQQ|
ALTER TABLE "sheet" ADD COLUMN "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|]
)
, ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
, whenM (tableExists "user") $ do
, whenM (columnExists "user" "plugin") $ do
-- <> is standard sql for /=
[executeQQ|
DELETE FROM "user" WHERE "plugin" <> 'LDAP';
ALTER TABLE "user" DROP COLUMN "plugin";
ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"';
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" json DEFAULT '"ldap"';
|]
)
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
, whenM (tableExists "user") $ do
[executeQQ|
ALTER TABLE "user" ADD COLUMN "notification_settings" json DEFAULT null;
UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null;
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" json NOT NULL DEFAULT '[]';
|]
)
, ( AppliedMigrationKey [migrationVersion|5.0.0|] [version|6.0.0|]
@ -200,7 +199,18 @@ customMigrations = Map.fromListWith (>>)
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
tableExists table = do
haveSchoolTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
case haveSchoolTable :: [Maybe (Single PersistValue)] of
haveTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
case haveTable :: [Maybe (Single PersistValue)] of
[Just _] -> return True
_other -> return False
columnExists :: MonadIO m
=> Text -- ^ Table
-> Text -- ^ Column
-> ReaderT SqlBackend m Bool
columnExists table column = do
haveColumn <- [sqlQQ|SELECT column_name FROM information_schema.columns WHERE table_name=#{table} and column_name=#{column};|]
case haveColumn :: [Single PersistValue] of
[_] -> return True
_other -> return False

2
src/Settings.hs
View File

@ -81,7 +81,7 @@ data AppSettings = AppSettings
, appMailObjectDomain :: Text
, appMailVerp :: VerpMode
, appMailSupport :: Address
, appJobWorkers :: Int
, appJobWorkers :: Natural
, appJobFlushInterval :: Maybe NominalDiffTime
, appJobCronInterval :: NominalDiffTime
, appJobStaleThreshold :: NominalDiffTime

1
src/Utils.hs
View File

@ -20,6 +20,7 @@ import Utils.DateTime as Utils
import Utils.PathPiece as Utils
import Utils.Message as Utils
import Utils.Lang as Utils
import Control.Lens as Utils (none)
import Text.Blaze (Markup, ToMarkup)

4
src/Utils/Sql.hs
View File

@ -6,7 +6,7 @@ import ClassyPrelude.Yesod
import Database.Persist.Sql
import Database.PostgreSQL.Simple (sqlErrorHint)
import Database.PostgreSQL.Simple (SqlError(SqlError), sqlErrorHint)
import Control.Monad.Catch (handleIf)
import Data.Time.Clock
@ -18,7 +18,7 @@ setSerializable act = setSerializable' (0 :: Integer)
setSerializable' (min 10 -> logBackoff) =
handleIf
(\e -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint e)
(\SqlError{sqlErrorHint} -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint)
(\e -> do
let
delay :: NominalDiffTime

7
stack.yaml
View File

@ -1,4 +1,7 @@
flags: {}
flags:
uniworx:
dev: true
library-only: true
nix:
packages: []
@ -38,4 +41,6 @@ extra-deps:
- saltine-0.1.0.1
- hlint-test-0.1.0.0
resolver: lts-10.5

2
test.sh
View File

@ -11,4 +11,4 @@ if [[ -d .stack-work-test ]]; then
trap move-back EXIT
fi
stack test --flag uniworx:dev --flag uniworx:library-only ${@}
stack build --test --fast --flag uniworx:dev --flag uniworx:library-only ${@}

11
test/CronSpec.hs
View File

@ -5,7 +5,6 @@ module CronSpec where
import TestImport
import Cron
import Numeric.Natural
import Data.Time
import Data.Time.Clock.System
@ -22,9 +21,9 @@ sampleCron :: Natural -> Cron -> [UTCTime]
sampleCron n = go n baseTime Nothing
where
go 0 _ _ _ = []
go n t mPrev cron = case nextCronMatch utcTZ mPrev t cron of
MatchAsap -> t : go (pred n) t (Just t) cron
MatchAt t' -> t' : go (pred n) t' (Just t') cron
go (pred -> n') t mPrev cron = case nextCronMatch utcTZ mPrev t cron of
MatchAsap -> t : go n' t (Just t) cron
MatchAt t' -> t' : go n' t' (Just t') cron
MatchNone -> []
@ -32,8 +31,8 @@ spec :: Spec
spec = do
describe "Cron" $ do
it "generates correct example series" . mapM_ seriesExample $
[ (Cron CronAsap Nothing CronScheduleBefore, [baseTime])
, (Cron CronAsap (Just $ CronPeriod 10 CronAsap) CronScheduleBefore, iterate (addUTCTime 10) baseTime)
[ (Cron CronAsap CronRepeatNever 0 (Right CronNotScheduled), [baseTime])
, (Cron CronAsap (CronRepeatScheduled CronAsap) 10 (Right CronNotScheduled), iterate (addUTCTime 10) baseTime)
]
seriesExample :: (Cron, [UTCTime]) -> Expectation

27
test/Handler/HomeSpec.hs
View File

@ -6,30 +6,11 @@ import TestImport
spec :: Spec
spec = withApp $ do
describe "Homepage" $ do
it "loads the index and checks it looks right" $ do
get HomeR
statusIs 200
htmlAnyContain "h1" "a modern framework for blazing fast websites"
request $ do
setMethod "POST"
setUrl HomeR
addToken
fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
byLabel "What's on the file?" "Some Content"
setMethod "GET"
setUrl HomeR
addRequestHeader ("Accept-Language", "de")
statusIs 200
-- more debugging printBody
htmlAllContain ".upload-response" "text/plain"
htmlAllContain ".upload-response" "Some Content"
-- This is a simple example of using a database access in a test. The
-- test will succeed for a fresh scaffolded site with an empty database,
-- but will fail on an existing database with a non-empty user table.
it "leaves the user table empty" $ do
get HomeR
statusIs 200
users <- runDB $ selectList ([] :: [Filter User]) []
assertEq "user table empty" 0 $ length users
htmlAnyContain "h1" "Aktuelle Termine"

15
test/Handler/ProfileSpec.hs
View File

@ -4,15 +4,16 @@ module Handler.ProfileSpec (spec) where
import TestImport
import qualified Data.CaseInsensitive as CI
spec :: Spec
spec = withApp $ do
describe "Profile page" $ do
it "asserts no access to my-account for anonymous users" $ do
get ProfileR
statusIs 403
loc <- getLocation
assertEq "Redirect is to Login" loc
either (fail . unpack) (\_ -> return ()) =<< followRedirect
statusIs 200
it "asserts access to my-account for authenticated users" $ do
userEntity <- createUser "foo"
@ -20,11 +21,3 @@ spec = withApp $ do
get ProfileR
statusIs 200
it "asserts user's information is shown" $ do
userEntity <- createUser "bar"
authenticateAs userEntity
get ProfileR
let (Entity _ user) = userEntity
htmlAnyContain ".username" . unpack . CI.original $ userIdent user

91
test/TestImport.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module TestImport
( module TestImport
, module X
@ -11,11 +6,10 @@ module TestImport
import Application (makeFoundation, makeLogWare)
import ClassyPrelude as X hiding (delete, deleteBy, Handler)
import Database.Persist as X hiding (get)
import Database.Persist.Sql (SqlPersistM, SqlBackend, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName)
import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool, rawExecute, unSingle, connEscapeName, sqlQQ)
import Foundation as X
import Model as X
import Test.Hspec as X
import Text.Shakespeare.Text (st)
import Yesod.Default.Config2 (useEnv, loadYamlSettings)
import Yesod.Auth as X
import Yesod.Test as X
@ -23,8 +17,12 @@ import Yesod.Core.Unsafe (fakeHandlerGetLogger)
import Test.QuickCheck as X
import Test.QuickCheck.Gen as X
import Data.Default as X
import Test.QuickCheck.Instances as X
import Test.QuickCheck.Instances as X ()
import System.IO as X (hPrint, hPutStrLn, stderr)
import Jobs (handleJobs, stopJobCtl)
import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase)
import Data.Pool (destroyAllResources)
import Settings
@ -34,60 +32,63 @@ import qualified Data.CaseInsensitive as CI
runDB :: SqlPersistM a -> YesodExample UniWorX a
runDB query = do
app <- getTestYesod
liftIO $ runDBWithApp app query
app <- getTestYesod
liftIO $ runDBWithApp app query
runDBWithApp :: UniWorX -> SqlPersistM a -> IO a
runDBWithApp app query = runSqlPersistMPool query (appConnPool app)
runDBWithApp :: MonadIO m => UniWorX -> SqlPersistM a -> m a
runDBWithApp app query = liftIO $ runSqlPersistMPool query (appConnPool app)
runHandler :: Handler a -> YesodExample UniWorX a
runHandler handler = do
app <- getTestYesod
fakeHandlerGetLogger appLogger app handler
app <- getTestYesod
fakeHandlerGetLogger appLogger app handler
withApp :: SpecWith (TestApp UniWorX) -> Spec
withApp = before $ do
settings <- loadYamlSettings
["config/test-settings.yml", "config/settings.yml"]
[]
useEnv
foundation <- makeFoundation settings
wipeDB foundation
logWare <- liftIO $ makeLogWare foundation
return (foundation, logWare)
withApp :: YSpec UniWorX -> Spec
withApp = around $ \act -> runResourceT $ do
settings <- liftIO $ loadYamlSettings
["config/test-settings.yml", "config/settings.yml"]
[]
useEnv
foundation <- makeFoundation settings
let
stopDBAccess = do
stopJobCtl foundation
liftIO . destroyAllResources $ appConnPool foundation
bracket_ stopDBAccess (handleJobs foundation) $ wipeDB foundation
logWare <- makeLogWare foundation
lift $ act (foundation, logWare)
-- This function will truncate all of the tables in your database.
-- 'withApp' calls it before each test, creating a clean environment for each
-- spec to run in.
wipeDB :: UniWorX -> IO ()
wipeDB :: (MonadResourceBase m, MonadMask m) => UniWorX -> m ()
wipeDB app = runDBWithApp app $ do
tables <- getTables
sqlBackend <- ask
tables <- map unSingle <$> [sqlQQ|SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'|]
sqlBackend <- ask
let escapedTables = map (connEscapeName sqlBackend . DBName) tables
query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables
rawExecute query []
getTables :: MonadIO m => ReaderT SqlBackend m [Text]
getTables = do
tables <- rawSql [st|
SELECT table_name
FROM information_schema.tables
WHERE table_schema = 'public';
|] []
return $ map unSingle tables
let escapedTables = map (connEscapeName sqlBackend . DBName) $ filter (not . (`elem` protected)) tables
query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables ++ " RESTART IDENTITY"
protected = ["applied_migration"]
rawExecute query []
-- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag
-- being set in test-settings.yaml, which enables dummy authentication in
-- Foundation.hs
--
-- FIXME
authenticateAs :: Entity User -> YesodExample UniWorX ()
authenticateAs (Entity _ User{..}) = do
request $ do
setMethod "POST"
addPostParam "ident" $ CI.original userIdent
setUrl $ AuthR $ PluginR "dummy" []
request $ do
setMethod "GET"
addRequestHeader ("Accept-Language", "de")
setUrl $ AuthR LoginR
request $ do
setMethod "POST"
addTokenFromCookie
byLabelExact "Nutzer-Kennung" $ CI.original userIdent
setUrl $ AuthR $ PluginR "dummy" []
-- | Create a user. The dummy email entry helps to confirm that foreign-key
-- checking is switched off in wipeDB for those database backends which need it.
@ -106,4 +107,6 @@ createUser userIdent = do
userDateFormat = userDefaultDateFormat
userTimeFormat = userDefaultTimeFormat
userDownloadFiles = userDefaultDownloadFiles
userMailLanguages = def
userNotificationSettings = def
runDB $ insertEntity User{..}