Setup hlint & yesod

hlint/Hlint.hs

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

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

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

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
+    appJobCtl <- liftIO $ newTVarIO Map.empty
-        chan <- newBroadcastTMChan
+    appCronThread <- liftIO newEmptyTMVarIO
-        recvChan <- dupTMChan chan
-        return (chan, recvChan)
 
     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
+shutdownApp = stopJobCtl
-  liftIO . atomically $ mapM_ closeTMChan appJobCtl
 
 
 ---------------------------------------------

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
     }

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)
 

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 ()
+handleJobs :: ( MonadResource m
--- | Read control commands from `appJobCtl` and address them as they come in
+              , 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
+handleJobs foundation@UniWorX{..} = do
-  jobCrontab <- liftIO $ newTVarIO HashMap.empty
+  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
+      removeChan = atomically . modifyTVar' appJobCtl . Map.delete =<< myThreadId
-    in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
+      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)
+  registeredCron <- liftIO newEmptyTMVarIO
-  liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
+  let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
-    writeJobCtlBlock JobCtlDetermineCrontab
+        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
+execCrontab = evalStateT go HashMap.empty
-  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
   where
-    acc :: NominalDiffTime
+    go = do
-    acc = 1e-3
+      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
+      now <- liftIO getCurrentTime
-    applyJitter seed t = do
+      currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
-      appInstance <- getsYesod appInstanceID
+        crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
-      let
+        case crontab' of
-        halfRange = truncate $ 0.5 / acc
+          Nothing -> return Nothing
-        diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
+          Just crontab -> Just <$> do
-      return $ addUTCTime diff t
+            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)
+      case currentState of
-    earliestJob lastTimes crontab now = foldr go Nothing $ HashMap.toList crontab
+        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
+        acc :: NominalDiffTime
-          | Just (_, t') <- mbPrev
+        acc = 1e-3
-          , t' < t
+
-          = mbPrev
+        applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
-          | otherwise
+        applyJitter seed t = do
-          = Just (jobCtl, t)
+          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 :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
-    waitUntil crontabTV crontab nextTime = runResourceT $ do
+        waitUntil crontabTV crontab nextTime = runResourceT $ do
-      diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
+          diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
-      let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
+          let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
-          waitTime'
+              waitTime'
-            | diffT < acc = "Done"
+                | diffT < acc = "Done"
-            | otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
+                | otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
-      $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
+          $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
-      if
+          if
-        | diffT < acc -> return True
+            | diffT < acc -> return True
-        | otherwise   -> do
+            | otherwise   -> do
-            retVar <- liftIO newEmptyTMVarIO
+                retVar <- liftIO newEmptyTMVarIO
-            void $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread)
+                void . liftIO . forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar
-            let
+                let
-              awaitDelayThread = False <$ takeTMVar retVar
+                  awaitDelayThread = False <$ takeTMVar retVar
-              awaitCrontabChange = do
+                  awaitCrontabChange = do
-                crontab' <- readTVar crontabTV
+                    crontab' <- tryReadTMVar crontabTV
-                True <$ guard (crontab /= crontab')
+                    True <$ guard (Just crontab /= crontab')
-            crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
+                crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
-            bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
+                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

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
+  wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO
-  liftIO . atomically $ writeTMChan chan cmd
+  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
-
-
-

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))))
   }

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);
+    QuasiQuoter: ^{TableName} @{ColumnName} (escaped as column/table-name; value determined from current model);
-                  #{anything} (no escaping);
+                  #{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" DROP COLUMN "id";
-            ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
+          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;
+          ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" json NOT NULL DEFAULT '[]';
-          UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null;
         |]
     )
   , ( 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}); |]
+  haveTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
-  case haveSchoolTable :: [Maybe (Single PersistValue)] of
+  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
+  

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

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)

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

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

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 ${@}

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
+    go (pred -> n') t mPrev cron = case nextCronMatch utcTZ mPrev t cron of
-      MatchAsap -> t : go (pred n) t (Just t) cron
+      MatchAsap -> t : go n' t (Just t) cron
-      MatchAt t' -> t' : go (pred 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 CronRepeatNever 0 (Right CronNotScheduled), [baseTime])
-      , (Cron CronAsap (Just $ CronPeriod 10 CronAsap) CronScheduleBefore, iterate (addUTCTime 10) baseTime)
+      , (Cron CronAsap (CronRepeatScheduled CronAsap) 10 (Right CronNotScheduled), iterate (addUTCTime 10) baseTime)
       ]
 
 seriesExample :: (Cron, [UTCTime]) -> Expectation

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"
+            setMethod "GET"
-              setUrl HomeR
+            setUrl HomeR
-              addToken
+            addRequestHeader ("Accept-Language", "de")
-              fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
-              byLabel "What's on the file?" "Some Content"
-
           statusIs 200
-          -- more debugging printBody
+          htmlAnyContain "h1" "Aktuelle Termine"
-          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

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

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
+  app <- getTestYesod
-    liftIO $ runDBWithApp app query
+  liftIO $ runDBWithApp app query
 
-runDBWithApp :: UniWorX -> SqlPersistM a -> IO a
+runDBWithApp :: MonadIO m => UniWorX -> SqlPersistM a -> m a
-runDBWithApp app query = runSqlPersistMPool query (appConnPool app)
+runDBWithApp app query = liftIO $ runSqlPersistMPool query (appConnPool app)
 
 runHandler :: Handler a -> YesodExample UniWorX a
 runHandler handler = do
-    app <- getTestYesod
+  app <- getTestYesod
-    fakeHandlerGetLogger appLogger app handler
+  fakeHandlerGetLogger appLogger app handler
 
 
-withApp :: SpecWith (TestApp UniWorX) -> Spec
+withApp :: YSpec UniWorX -> Spec
-withApp = before $ do
+withApp = around $ \act -> runResourceT $ do
-    settings <- loadYamlSettings
+  settings <- liftIO $ loadYamlSettings
-        ["config/test-settings.yml", "config/settings.yml"]
+    ["config/test-settings.yml", "config/settings.yml"]
-        []
+    []
-        useEnv
+    useEnv
-    foundation <- makeFoundation settings
+  foundation <- makeFoundation settings
-    wipeDB foundation
+  let
-    logWare <- liftIO $ makeLogWare foundation
+    stopDBAccess = do
-    return (foundation, logWare)
+      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
+  tables <- map unSingle <$> [sqlQQ|SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'|]
-    sqlBackend <- ask
+  sqlBackend <- ask
 
-    let escapedTables = map (connEscapeName sqlBackend . DBName) tables
+  let escapedTables = map (connEscapeName sqlBackend . DBName) $ filter (not . (`elem` protected)) tables
-        query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables
+      query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables ++ " RESTART IDENTITY"
-    rawExecute query []
+      protected = ["applied_migration"]
-
+  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
 
 -- | 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
+  request $ do
-        setMethod "POST"
+    setMethod "GET"
-        addPostParam "ident" $ CI.original userIdent
+    addRequestHeader ("Accept-Language", "de")
-        setUrl $ AuthR $ PluginR "dummy" []
+    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{..}