diff --git a/hlint/Hlint.hs b/hlint/Hlint.hs new file mode 100644 index 000000000..4990226af --- /dev/null +++ b/hlint/Hlint.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hlint-test -optF --git -optF -j -optF src #-} diff --git a/models b/models index 88e88243f..d682b5020 100644 --- a/models +++ b/models @@ -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 diff --git a/package.yaml b/package.yaml index 246f6bcf3..820a16e46 100644 --- a/package.yaml +++ b/package.yaml @@ -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: diff --git a/src/Application.hs b/src/Application.hs index 3757d98f7..94f30e34c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 --------------------------------------------- diff --git a/src/Foundation.hs b/src/Foundation.hs index cd09b4ad8..4cb048b8d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 } diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 51f05a9cb..9d80282a3 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -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) diff --git a/src/Jobs.hs b/src/Jobs.hs index 112a1376f..e3b4b0276 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -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 diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index db5f2d8e5..bc9ab4fee 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -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 - - - diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 20af81933..6a6e65109 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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)))) } diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 92bc5c8d3..bfb645af6 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -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 + diff --git a/src/Settings.hs b/src/Settings.hs index 82b7f7ec0..46e35fdf1 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -81,7 +81,7 @@ data AppSettings = AppSettings , appMailObjectDomain :: Text , appMailVerp :: VerpMode , appMailSupport :: Address - , appJobWorkers :: Int + , appJobWorkers :: Natural , appJobFlushInterval :: Maybe NominalDiffTime , appJobCronInterval :: NominalDiffTime , appJobStaleThreshold :: NominalDiffTime diff --git a/src/Utils.hs b/src/Utils.hs index a95c79722..9da6dbe8b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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) diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index f56ac38a2..aae593c05 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -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 diff --git a/stack.yaml b/stack.yaml index 2551d1ab6..f046a45e2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/test.sh b/test.sh index 9e3db3ebe..26f865cb1 100755 --- a/test.sh +++ b/test.sh @@ -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 ${@} diff --git a/test/CronSpec.hs b/test/CronSpec.hs index af942ea77..ee9abe812 100644 --- a/test/CronSpec.hs +++ b/test/CronSpec.hs @@ -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 diff --git a/test/Handler/HomeSpec.hs b/test/Handler/HomeSpec.hs index 5ad322254..35eb111d1 100644 --- a/test/Handler/HomeSpec.hs +++ b/test/Handler/HomeSpec.hs @@ -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" diff --git a/test/Handler/ProfileSpec.hs b/test/Handler/ProfileSpec.hs index e0f8ed5c2..b14e59868 100644 --- a/test/Handler/ProfileSpec.hs +++ b/test/Handler/ProfileSpec.hs @@ -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 diff --git a/test/TestImport.hs b/test/TestImport.hs index bf7f56729..32b83ad33 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -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{..}