?|] -- SJ: confused why ## is needed here either?
+
+modalWidget :: Html -> WidgetT site IO () -> WidgetT site IO ()
+modalWidget modalTrigger modalContent = do
+ uniqueId <- newIdent
+ let modalTriggerId = cons '#' uniqueId -- SJ: I am confused why this is needed here?
+ modalId :: Int32
+ modalId = 13
+ $(widgetFile "widgets/modalWidget")
+ [whamlet|
#{modalTrigger}|] -- SJ: confused why ## is needed here either?
+
+modal :: Text -> Maybe [Char] -> WidgetT site IO ()
+modal modalTrigger (Just modalContent) = do -- WARNING: ModalContent should not have length 11. SJ: This is possibly bad. See Template!
let
modalId :: Int32
modalId = 13
diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs
deleted file mode 100644
index fa2186bf0..000000000
--- a/src/Handler/Utils/Term.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-module Handler.Utils.Term where
-
-import Import
-import qualified Data.Text as T
-import Model.Types
--- import Data.Maybe
-
-
-termActiveField :: Field Handler TermId
-termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
-
-termActiveOld :: Field Handler TermIdentifier
-termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
-
-termNewField :: Field Handler TermIdentifier
-termNewField = checkMMap checkTerm termToText textField
- where
- errTextParse :: Text
- errTextParse = "Semester: S oder W gefolgt von Jahreszahl"
-
- errTextFreigabe :: TermIdentifier -> Text
- errTextFreigabe ti = "Semester " `T.append` (termToText ti) `T.append` " wurde noch nicht freigegeben."
-
- checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier)
- checkTerm t = case termFromText t of
- Left _ -> return $ Left errTextParse
- res@(Right _) -> return res
-
-validateTerm :: Term -> [Text]
-validateTerm (Term{..}) =
- [ msg | (False, msg) <-
- [ --startOk
- ( termStart `withinTerm` termName
- , "Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein."
- )
- , -- endOk
- ( termStart < termEnd
- , "Semester darf nicht enden, bevor es begann."
- )
- , -- startOk
- ( termLectureStart < termLectureEnd
- , "Vorlesungszeit muss vor ihrem Ende anfgangen."
- )
- , -- lecStartOk
- ( termStart <= termLectureStart
- , "Semester muss vor der Vorlesungszeit beginnen."
- )
- , -- lecEndOk
- ( termEnd >= termLectureEnd
- , "Vorlesungszeit muss vor dem Semester enden."
- )
- ] ]
diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs
index b972555a7..fb196c933 100644
--- a/src/Handler/Utils/Zip.hs
+++ b/src/Handler/Utils/Zip.hs
@@ -56,7 +56,7 @@ consumeZip = unZipStream `fuseUpstream` consumeZip'
Just (Left ZipEntry{..}) -> do
contentChunks <- toConsumer accContents
let
- fileTitle = normalise $ makeValid zipEntryName
+ fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise $ makeValid zipEntryName
fileModified = localTimeToUTC utc zipEntryTime
fileContent
| hasTrailingPathSeparator zipEntryName = Nothing
@@ -108,7 +108,7 @@ sourceFiles fInfo
acceptFile :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> m File
acceptFile fInfo = do
- let fileTitle = unpack $ fileName fInfo
+ let fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise . unpack $ fileName fInfo
fileModified <- liftIO getCurrentTime
fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
return File{..}
diff --git a/src/Import.hs b/src/Import.hs
index a10200156..cdb0ec16f 100644
--- a/src/Import.hs
+++ b/src/Import.hs
@@ -4,3 +4,4 @@ module Import
import Foundation as Import
import Import.NoFoundation as Import
+
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 2157df182..19d0bb34d 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -1,22 +1,28 @@
{-# LANGUAGE CPP #-}
module Import.NoFoundation
( module Import
+ , addMessage, addMessageI
) where
-import ClassyPrelude.Yesod as Import
-import Model as Import
-import Settings as Import
-import Settings.StaticFiles as Import
-import Yesod.Auth as Import
-import Yesod.Core.Types as Import (loggerSet)
-import Yesod.Default.Config2 as Import
-import Utils as Import
+import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI)
+import Model as Import
+import Model.Types.JSON as Import
+import Model.Migration as Import
+import Settings as Import
+import Settings.StaticFiles as Import
+import Yesod.Auth as Import
+import Yesod.Core.Types as Import (loggerSet)
+import Yesod.Default.Config2 as Import
+import Utils as Import
-import Data.Fixed as Import
+import Data.Fixed as Import
-import CryptoID as Import
-import Data.UUID as Import (UUID)
+import CryptoID as Import
+import Data.UUID as Import (UUID)
+import Text.Lucius as Import
-import Text.Lucius as Import
+import Text.Shakespeare.Text as Import hiding (text, stext)
+
+import Data.Universe as Import
diff --git a/src/Jobs.hs b/src/Jobs.hs
new file mode 100644
index 000000000..e82ad1060
--- /dev/null
+++ b/src/Jobs.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE NoImplicitPrelude
+ , RecordWildCards
+ , TemplateHaskell
+ , OverloadedStrings
+ , FlexibleContexts
+ , ViewPatterns
+ , TypeFamilies
+ , DeriveGeneric
+ , DeriveDataTypeable
+ #-}
+
+module Jobs
+ ( handleJobs
+ , Job(..), Notification(..)
+ ) where
+
+import Import
+
+import Data.Conduit.TMChan
+import qualified Data.Conduit.List as C
+
+import Data.Aeson (fromJSON, Result(..), defaultOptions, Options(..))
+import qualified Data.Aeson as Aeson
+import Data.Aeson.TH (deriveJSON)
+import Database.Persist.Sql (rawExecute, fromSqlKey)
+
+
+data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
+ deriving (Eq, Ord, Show, Read)
+data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId, nTimestamp :: UTCTime }
+ deriving (Eq, Ord, Show, Read)
+
+deriveJSON defaultOptions
+ { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+ , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+ , tagSingleConstructors = True
+ } ''Job
+
+deriveJSON defaultOptions
+ { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+ , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+ , tagSingleConstructors = True
+ } ''Notification
+
+data JobQueueException = JInvalid QueuedJob
+ | JLocked QueuedJobId UUID UTCTime
+ | JNonexistant QueuedJobId
+ deriving (Read, Show, Eq, Generic, Typeable)
+
+instance Exception JobQueueException
+
+
+handleJobs :: UniWorX -> IO ()
+handleJobs foundation@UniWorX{..} = unsafeHandler foundation . bracket_ logStart logStop . runConduit $ sourceTMChan appJobCtl .| handleJobs'
+ where
+ logStart = $(logDebugS) "Jobs" "Started"
+ logStop = $(logDebugS) "Jobs" "Shutting down"
+
+handleJobs' :: Sink JobCtl Handler ()
+handleJobs' = C.mapM_ $ void . handleAny ($(logErrorS) "Jobs" . tshow) . handleCmd
+ where
+ handleQueueException :: MonadLogger m => JobQueueException -> m ()
+ handleQueueException (JInvalid j) = $(logWarnS) "Jobs" $ "Invalid QueuedJob: " ++ tshow j
+ handleQueueException (JNonexistant jId) = $(logInfoS) "Jobs" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
+ handleQueueException (JLocked jId lInstance lTime) = $(logDebugS) "Jobs" $ "Saw locked QueuedJob: " ++ tshow (jId, lInstance, lTime)
+
+ handleCmd NCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreated ] .| C.mapM_ cmdPerform
+ handleCmd (NCtlPerform jId) = handle handleQueueException . (`finally` jUnlock jId) $ do
+ j@QueuedJob{..} <- jLock jId
+
+ let
+ content :: Job
+ Aeson.Success content = fromJSON queuedJobContent
+
+ $(logDebugS) "Jobs" $ "Would do: " <> tshow content -- FIXME
+
+ runDB $ delete jId
+
+jLock :: QueuedJobId -> Handler QueuedJob
+jLock jId = runDB $ do
+ rawExecute "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE" []
+ j@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
+ maybe (return ()) throwM $ JLocked <$> pure jId <*> queuedJobLockInstance <*> queuedJobLockTime
+ let isSuccess (Aeson.Success _) = True
+ isSuccess _ = False
+ unless (isSuccess (fromJSON queuedJobContent :: Result Job)) . throwM $ JInvalid j
+ instanceID <- getsYesod appInstanceID
+ now <- liftIO getCurrentTime
+ updateGet jId [ QueuedJobLockInstance =. Just instanceID
+ , QueuedJobLockTime =. Just now
+ ]
+
+jUnlock :: QueuedJobId -> Handler ()
+jUnlock jId = runDB $ update jId [ QueuedJobLockInstance =. Nothing
+ , QueuedJobLockTime =. Nothing
+ ]
+
+
+cmdPerform :: ( MonadHandler m
+ , HandlerSite m ~ UniWorX
+ ) => QueuedJobId -> m ()
+cmdPerform (NCtlPerform -> cmd) = do
+ chan <- getsYesod appJobCtl
+ liftIO . atomically $ writeTMChan chan cmd
diff --git a/src/Model.hs b/src/Model.hs
index 0bcc47ec9..55fcfb78c 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -9,6 +9,10 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+
module Model
( module Model
, module Model.Types
@@ -19,18 +23,29 @@ import Database.Persist.Quasi
-- import Data.Time
-- import Data.ByteString
import Model.Types
+
import Data.UUID
import Data.Aeson (Value)
import Data.Aeson.TH (deriveJSON, defaultOptions)
+import Data.CaseInsensitive (CI)
+import Data.CaseInsensitive.Instances ()
+
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
-share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"]
+share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
$(persistFileWith lowerCaseSettings "models")
-data Notification = SubmissionRated SubmissionId UTCTime
- deriving (Eq, Ord, Show, Read)
-deriveJSON defaultOptions ''Notification
+-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
+deriving instance Eq (Unique Course)
+data PWEntry = PWEntry
+ { pwUser :: User
+ , pwHash :: Text
+ } deriving (Show)
+$(deriveJSON defaultOptions ''PWEntry)
+
+submissionRatingDone :: Submission -> Bool
+submissionRatingDone Submission{..} = isJust submissionRatingPoints
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
new file mode 100644
index 000000000..54ec40156
--- /dev/null
+++ b/src/Model/Migration.hs
@@ -0,0 +1,201 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies, FlexibleInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Model.Migration
+ ( migrateAll
+ ) where
+
+import ClassyPrelude.Yesod
+
+import Utils (lastMaybe)
+
+import Model
+import Model.Migration.Version
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Data.Set ()
+import qualified Data.Set as Set
+
+import Database.Persist.Sql
+import Database.Persist.Postgresql
+
+import Text.Read (readMaybe)
+import Data.CaseInsensitive (CI)
+
+-- Database versions must follow https://pvp.haskell.org:
+-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
+-- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
+
+-- Note that only one automatic migration is done (after all manual migrations).
+-- Manual migrations can therefore not rely on non-breaking changes being applied when they are executed (i.e. columns existing, that were added as non-breaking changes after InitialVersion)
+-- If that is inconvenient a custom migration between minor version numbers can be formulated using `migration`, `runMigration`, and manually defined `EntityDef`s so as to use persistent's automatic migration system
+
+-- Database versions must be marked with git tags:
+-- The first commit corresponding to a new database version x.x.x must be tagged dbx.x.x
+-- Tags should be annotated with a description of the changes affecting the database.
+--
+-- Example:
+-- $ git tag -a db0.0.0 -m "Simplified format of UserTheme"
+--
+-- Doing so creates sort of parallel commit history tracking changes to the database schema
+
+
+share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
+ [persistLowerCase|
+ AppliedMigration json
+ from MigrationVersion
+ to Version
+ time UTCTime
+ UniqueAppliedMigration from
+ Primary from to
+ deriving Show Eq Ord
+ |]
+
+migrateAll :: MonadIO m => ReaderT SqlBackend m ()
+migrateAll = do
+ runMigration $ do
+ -- Manual migrations to go to InitialVersion below:
+ migrateEnableExtension "citext"
+
+ migrateDBVersioning
+
+ appliedMigrations <- map entityKey <$> selectList [] []
+ let
+ missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
+ doCustomMigration acc desc migration = acc <* do
+ let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc
+ appliedMigrationTime <- liftIO getCurrentTime
+ _ <- migration
+ insert AppliedMigration{..}
+ -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey
+ Map.foldlWithKey doCustomMigration (return ()) missingMigrations
+
+ runMigration migrateAll'
+
+{-
+ 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);
+-}
+
+
+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
+ userThemes <- [sqlQQ| SELECT "id", "theme" FROM "user"; |]
+ forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of
+ Just v
+ | Just theme <- fromPathPiece v -> update uid [UserTheme =. theme]
+ other -> error $ "Could not parse theme: " <> show other
+ )
+ , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
+ , whenM (tableExists "sheet") $ -- Better JSON encoding
+ [executeQQ|
+ ALTER TABLE "sheet" ALTER COLUMN "type" TYPE json USING "type"::json;
+ ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE json USING "grouping"::json;
+ |]
+ )
+ , ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|]
+ , whenM (tableExists "school") $ 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
+ -- Convert columns containing SchoolId
+ whenM (tableExists "user_admin") $ do
+ [executeQQ|
+ ALTER TABLE "user_admin" DROP CONSTRAINT "user_admin_school_fkey";
+ ALTER TABLE "user_admin" ALTER COLUMN "school" TYPE citext USING "school"::citext;
+ |]
+ forM_ schoolTable $ \(Single idnr, Single ssh) ->
+ [executeQQ|
+ UPDATE "user_admin" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
+ |]
+ [executeQQ|
+ ALTER TABLE "user_admin" ADD CONSTRAINT "user_admin_school_fkey"
+ FOREIGN KEY (school) REFERENCES school(shorthand);
+ |]
+ whenM (tableExists "user_lecturer") $ do
+ [executeQQ|
+ ALTER TABLE "user_lecturer" DROP CONSTRAINT "user_lecturer_school_fkey";
+ ALTER TABLE "user_lecturer" ALTER COLUMN "school" TYPE citext USING "school"::citext;
+ |]
+ forM_ schoolTable $ \(Single idnr, Single ssh) ->
+ [executeQQ|
+ UPDATE "user_lecturer" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
+ |]
+ [executeQQ|
+ ALTER TABLE "user_lecturer" ADD CONSTRAINT "user_lecturer_school_fkey"
+ FOREIGN KEY (school) REFERENCES school(shorthand);
+ |]
+ whenM (tableExists "course") $ do
+ [executeQQ|
+ ALTER TABLE "course" DROP CONSTRAINT "course_school_fkey";
+ ALTER TABLE "course" ALTER COLUMN "school" TYPE citext USING "school"::citext;
+ |]
+ forM_ schoolTable $ \(Single idnr, Single ssh) ->
+ [executeQQ|
+ UPDATE "course" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
+ |]
+ [executeQQ|
+ ALTER TABLE "course" ADD CONSTRAINT "course_school_fkey"
+ FOREIGN KEY (school) REFERENCES school(shorthand);
+ |]
+ [executeQQ|
+ 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.
+ correctorLoads <- [sqlQQ| SELECT "id", "load" FROM "sheet_corrector"; |]
+ forM_ correctorLoads $ \(uid, Single str) -> case readMaybe str of
+ Just load -> update uid [SheetCorrectorLoad =. load]
+ _other -> error $ "Could not parse Load: " <> show str
+ [executeQQ|
+ ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE json USING "load"::json;
+ |]
+ )
+ , ( AppliedMigrationKey [migrationVersion|3.0.0|] [version|3.1.0|]
+ , whenM (tableExists "user") $ do
+ userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
+ [executeQQ|
+ ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT '';
+ |]
+ forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
+ Just name -> update uid [UserSurname =. name]
+ _other -> error $ "Empty userDisplayName found"
+ )
+ , ( 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 }';
+ |]
+ )
+ , ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
+ , whenM (tableExists "user") $ 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"';
+ |]
+ )
+ ]
+
+
+
+tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
+tableExists table = do
+ haveSchoolTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
+ case haveSchoolTable :: [Maybe (Single PersistValue)] of
+ [Just _] -> return True
+ _other -> return False
diff --git a/src/Model/Migration/Version.hs b/src/Model/Migration/Version.hs
new file mode 100644
index 000000000..37bbd8f3f
--- /dev/null
+++ b/src/Model/Migration/Version.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveLift, DeriveGeneric, DeriveDataTypeable #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Migration.Version
+ ( MigrationVersion(..)
+ , version, migrationVersion
+ , module Data.Version
+ ) where
+
+import ClassyPrelude.Yesod
+
+import Database.Persist.Sql
+import Text.ParserCombinators.ReadP
+import Data.Maybe (fromJust)
+
+import Data.Version
+
+import Data.Aeson.TH
+
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax (Lift)
+import qualified Language.Haskell.TH.Syntax as TH (lift)
+
+import Data.Data (Data)
+
+
+deriving instance Lift Version
+
+
+data MigrationVersion = InitialVersion | MigrationVersion Version
+ deriving (Eq, Ord, Show, Read, Generic, Typeable, Data, Lift)
+
+deriveJSON defaultOptions
+ { constructorTagModifier = toLower . fromJust . stripSuffix "Version"
+ , sumEncoding = UntaggedValue
+ } ''MigrationVersion
+
+instance PersistField MigrationVersion where
+ toPersistValue InitialVersion = PersistText "initial"
+ toPersistValue (MigrationVersion v) = PersistText . pack $ showVersion v
+
+ fromPersistValue (PersistText t)
+ | t == "initial" = return InitialVersion
+ | otherwise = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of
+ [x] -> Right $ MigrationVersion x
+ [] -> Left "No parse"
+ _ -> Left "Ambiguous parse"
+ fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x
+
+instance PersistFieldSql MigrationVersion where
+ sqlType _ = SqlString
+
+
+instance PersistField Version where
+ toPersistValue = PersistText . pack . showVersion
+
+ fromPersistValue (PersistText t) = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of
+ [x] -> Right x
+ [] -> Left "No parse"
+ _ -> Left "Ambiguous parse"
+ fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x
+
+instance PersistFieldSql Version where
+ sqlType _ = SqlString
+
+
+version, migrationVersion :: QuasiQuoter
+version = QuasiQuoter{..}
+ where
+ quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
+ [x] -> x
+ [] -> error "No parse"
+ _ -> error "Ambiguous parse"
+ quotePat = error "version cannot be used as pattern"
+ quoteType = error "version cannot be used as type"
+ quoteDec = error "version cannot be used as declaration"
+migrationVersion = QuasiQuoter{..}
+ where
+ quoteExp "initial" = TH.lift InitialVersion
+ quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
+ [x] -> MigrationVersion x
+ [] -> error "No parse"
+ _ -> error "Ambiguous parse"
+ quotePat = error "version cannot be used as pattern"
+ quoteType = error "version cannot be used as type"
+ quoteDec = error "version cannot be used as declaration"
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index ca925fafb..8acb5c58b 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -1,50 +1,96 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
-
+{-# LANGUAGE ViewPatterns #-}
+{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
module Model.Types where
import ClassyPrelude
import Utils
+import Control.Lens
+import Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Data.Map as Map
import Data.Fixed
+import Data.Monoid (Sum(..))
+import Data.Maybe (fromJust)
+import Data.Universe
+import Data.Universe.Helpers
+import Data.UUID.Types
-import Database.Persist.TH
+import Text.Read (readMaybe)
+
+import Database.Persist.TH hiding (derivePersistFieldJSON)
+import Model.Types.JSON
import Database.Persist.Class
import Database.Persist.Sql
import Web.HttpApiData
+import Web.PathPieces
import Data.Text (Text)
import qualified Data.Text as Text
+import qualified Data.Text.Lens as Text
-import Text.Read (readMaybe)
-
--- import Data.CaseInsensitive (CI)
+import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
-
-import Data.UUID
+import Data.CaseInsensitive.Instances ()
import Yesod.Core.Dispatch (PathPiece(..))
-import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..), encode, eitherDecode)
-import Data.Aeson.TH (deriveJSON, defaultOptions)
+import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
import GHC.Generics (Generic)
+import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Data.Typeable (Typeable)
+import qualified Yesod.Auth.Util.PasswordStore as PWStore
+
+
+instance PathPiece UUID where
+ fromPathPiece = Data.UUID.Types.fromString . unpack
+ toPathPiece = pack . toString
+
+instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
+ fromPathPiece = fmap CI.mk . fromPathPiece
+ toPathPiece = toPathPiece . CI.original
+
+instance {-# OVERLAPS #-} PathMultiPiece FilePath where
+ fromPathMultiPiece = Just . unpack . intercalate "/"
+ toPathMultiPiece = Text.splitOn "/" . pack
+
+instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
+ fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
+ toPathMultiPiece = toPathMultiPiece . CI.foldedCase
+
+instance ToHttpApiData (CI Text) where
+ toUrlPiece = CI.original
+
+instance FromHttpApiData (CI Text) where
+ parseUrlPiece = return . CI.mk
+
+
type Points = Centi
-toPoints :: Integral a => a -> Points
-toPoints = MkFixed . fromIntegral
+toPoints :: Integral a => a -> Points -- deprecated
+toPoints = fromIntegral
-fromPoints :: Integral a => Points -> a
-fromPoints (MkFixed c) = fromInteger c
+pToI :: Points -> Integer -- deprecated
+pToI = fromPoints
+
+fromPoints :: Integral a => Points -> a -- deprecated
+fromPoints = round
+
+instance DisplayAble Points
data SheetType
= Bonus { maxPoints :: Points }
@@ -52,36 +98,144 @@ data SheetType
| Pass { maxPoints, passingPoints :: Points }
| NotGraded
deriving (Show, Read, Eq)
+
+instance DisplayAble SheetType where
+ display (Bonus {..}) = tshow maxPoints <> " Bonuspunkte"
+ display (Normal{..}) = tshow maxPoints <> " Punkte"
+ display (Pass {..}) = "Bestanden ab " <> tshow (pToI passingPoints) <> " von " <> tshow maxPoints
+ display (NotGraded) = "Unbewertet"
+
deriveJSON defaultOptions ''SheetType
-derivePersistFieldJSON "SheetType"
+derivePersistFieldJSON ''SheetType
+
+data SheetTypeSummary = SheetTypeSummary
+ { sumBonusPoints :: Sum Points
+ , sumNormalPoints :: Sum Points
+ , numPassSheets :: Sum Int
+ , numNotGraded :: Sum Int
+ , achievedBonus :: Maybe (Sum Points)
+ , achievedNormal :: Maybe (Sum Points)
+ , achievedPasses :: Maybe (Sum Int)
+ } deriving (Generic)
+
+instance Monoid SheetTypeSummary where
+ mempty = memptydefault
+ mappend = mappenddefault
+
+sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary
+sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved }
+sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved }
+sheetTypeSum (Pass{..}, achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved}
+sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 }
+
data SheetGroup
- = Arbitrary { maxParticipants :: Int } -- Distinguish Limited/Arbitrary
+ = Arbitrary { maxParticipants :: Int }
| RegisteredGroups
| NoGroups
deriving (Show, Read, Eq)
deriveJSON defaultOptions ''SheetGroup
-derivePersistFieldJSON "SheetGroup"
+derivePersistFieldJSON ''SheetGroup
data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "SheetFileType"
+instance Universe SheetFileType where universe = universeDef
+instance Finite SheetFileType
+
instance PathPiece SheetFileType where
toPathPiece SheetExercise = "file"
toPathPiece SheetHint = "hint"
toPathPiece SheetSolution = "solution"
toPathPiece SheetMarking = "marking"
- fromPathPiece t =
- lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
+ fromPathPiece = finiteFromPathPiece
+
+-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
+instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
+ display SheetExercise = "Aufgabenstellung"
+ display SheetHint = "Hinweise"
+ display SheetSolution = "Musterlösung"
+ display SheetMarking = "Korrekturhinweise"
+
+-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
+-- partitionFileType' = groupMap
+
+partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
+partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs
+
+data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
+ deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+instance Universe SubmissionFileType where universe = universeDef
+instance Finite SubmissionFileType
+
+submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
+submissionFileTypeIsUpdate SubmissionOriginal = False
+submissionFileTypeIsUpdate SubmissionCorrected = True
+
+isUpdateSubmissionFileType :: Bool -> SubmissionFileType
+isUpdateSubmissionFileType False = SubmissionOriginal
+isUpdateSubmissionFileType True = SubmissionCorrected
+
+instance PathPiece SubmissionFileType where
+ toPathPiece SubmissionOriginal = "original"
+ toPathPiece SubmissionCorrected = "corrected"
+ fromPathPiece = finiteFromPathPiece
+
+instance DisplayAble SubmissionFileType where
+ display SubmissionOriginal = "Abgabe"
+ display SubmissionCorrected = "Korrektur"
+
+{-
+data DA = forall a . (DisplayAble a) => DA a
+
+instance DisplayAble DA where
+ display (DA x) = display x
+-}
+
+
+data UploadMode = NoUpload | Upload { unpackZips :: Bool }
+ deriving (Show, Read, Eq, Ord)
+
+deriveJSON defaultOptions ''UploadMode
+derivePersistFieldJSON ''UploadMode
data ExamStatus = Attended | NoShow | Voided
deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "ExamStatus"
-data Load = ByTutorial | ByProportion Rational
- deriving (Show, Read, Eq)
-derivePersistField "Load"
+-- | Specify a corrector's workload
+data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
+ = Load { byTutorial :: Maybe Bool -- ^ Just all from Tutorial, True if counting towards overall workload
+ , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders
+ }
+ deriving (Show, Read, Eq, Ord)
+
+deriveJSON defaultOptions ''Load
+derivePersistFieldJSON ''Load
+
+
+
+
+instance Semigroup Load where
+ (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
+ where
+ byTut''
+ | Nothing <- byTut = byTut'
+ | Nothing <- byTut' = byTut
+ | Just a <- byTut
+ , Just b <- byTut' = Just $ a || b
+
+instance Monoid Load where
+ mempty = Load Nothing 0
+ mappend = (<>)
+
+{- Use (is _ByTutorial) instead of this unneeded definition:
+ isByTutorial :: Load -> Bool
+ isByTutorial (ByTutorial {}) = True
+ isByTutorial _ = False
+-}
data Season = Summer | Winter
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
@@ -98,6 +252,8 @@ seasonFromChar c
where
(~=) = (==) `on` CI.mk
+instance DisplayAble Season
+
data TermIdentifier = TermIdentifier
{ year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
, season :: Season
@@ -107,25 +263,63 @@ data TermIdentifier = TermIdentifier
-- from_TermId_to_TermIdentifier = unTermKey
-- from_TermIdentifier_to_TermId = TermKey
---TODO: Enforce the number of digits within year, with parsing filling in the current leading digits? Goal: short urls
-termToText :: TermIdentifier -> Text
-termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show year
+shortened :: Iso' Integer Integer
+shortened = iso shorten expand
+ where
+ century = ($currentYear `div` 100) * 100
+ expand year
+ | 0 <= year
+ , year < 100 = let
+ options = [ expanded | offset <- [-1, 0, 1]
+ , let century' = century + offset * 100
+ expanded = century' + year
+ , $currentYear - 50 <= expanded
+ , expanded < $currentYear + 50
+ ]
+ in case options of
+ [unique] -> unique
+ failed -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed
+ | otherwise = year
+ shorten year
+ | $currentYear - 50 <= year
+ , year < $currentYear + 50 = year `mod` 100
+ | otherwise = year
+termToText :: TermIdentifier -> Text
+termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
+
+-- also see Hander.Utils.tidFromText
termFromText :: Text -> Either Text TermIdentifier
termFromText t
| (s:ys) <- Text.unpack t
- , Just year <- readMaybe ys
+ , Just (review shortened -> year) <- readMaybe ys
, Right season <- seasonFromChar s
= Right TermIdentifier{..}
- | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
-
+ | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
+
+termToRational :: TermIdentifier -> Rational
+termToRational TermIdentifier{..} = fromInteger year + seasonOffset
+ where
+ seasonOffset
+ | Summer <- season = 0
+ | Winter <- season = 0.5
+
+termFromRational :: Rational -> TermIdentifier
+termFromRational n = TermIdentifier{..}
+ where
+ year = floor n
+ remainder = n - (fromInteger $ floor n)
+ season
+ | remainder == 0 = Summer
+ | otherwise = Winter
+
instance PersistField TermIdentifier where
- toPersistValue = PersistText . termToText
- fromPersistValue (PersistText t) = termFromText t
+ toPersistValue = PersistRational . termToRational
+ fromPersistValue (PersistRational t) = Right $ termFromRational t
fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
instance PersistFieldSql TermIdentifier where
- sqlType _ = SqlString
+ sqlType _ = SqlNumeric 5 1
instance ToHttpApiData TermIdentifier where
toUrlPiece = termToText
@@ -142,33 +336,120 @@ instance ToJSON TermIdentifier where
instance FromJSON TermIdentifier where
parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
-
+
{- Must be defined in a later module:
-termField :: Field (HandlerT UniWorX IO) TermIdentifier
-termField = checkMMap (return . termFromText) termToText textField
- -- TODO: this is too simple and inconvenient, use selector and year picker
--}
+ termField :: Field (HandlerT UniWorX IO) TermIdentifier
+ termField = checkMMap (return . termFromText) termToText textField
+ See Handler.Utils.Form.termsField and termActiveField
+-}
withinTerm :: Day -> TermIdentifier -> Bool
time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
- where
- timeYear = fst3 $ toGregorian time
- termYear = year term
-
+ where
+ timeYear = fst3 $ toGregorian time
+ termYear = year term
+
data StudyFieldType = FieldPrimary | FieldSecondary
deriving (Eq, Ord, Enum, Show, Read, Bounded)
derivePersistField "StudyFieldType"
-derivePersistField "UUID"
+instance PersistField UUID where
+ toPersistValue = PersistDbSpecific . toASCIIBytes
+ fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ fromText t
+ fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs
+ fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs
+ fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x
-instance PersistField Value where
- toPersistValue = PersistDbSpecific . toStrict . encode
+instance PersistFieldSql UUID where
+ sqlType _ = SqlOther "uuid"
- fromPersistValue (PersistDbSpecific t) = first pack . eitherDecode $ fromStrict t
- fromPersistValue (PersistByteString t) = first pack . eitherDecode $ fromStrict t
- fromPersistValue v = Left $ "JSON values must be converted from PersistDbSpecific (got: " ++ tshow v ++ ")"
+instance DisplayAble StudyFieldType
-instance PersistFieldSql Value where
- sqlType _ = SqlOther "json"
+data Theme
+ = ThemeDefault
+ | ThemeLavender
+ | ThemeNeutralBlue
+ | ThemeAberdeenReds
+ | ThemeMossGreen
+ | ThemeSkyLove
+ deriving (Eq, Ord, Bounded, Enum, Show, Read)
+
+deriveJSON defaultOptions
+ { constructorTagModifier = fromJust . stripPrefix "Theme"
+ } ''Theme
+
+$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
+
+instance Universe Theme where universe = universeDef
+instance Finite Theme
+
+instance PathPiece Theme where
+ toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
+ fromPathPiece = finiteFromPathPiece
+
+$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
+
+derivePersistField "Theme"
+
+
+newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
+ deriving (Show, Read, Eq)
+
+instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
+ fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
+ toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName
+
+newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
+ deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
+
+data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
+ deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+
+data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
+ deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
+
+deriveJSON defaultOptions
+ { constructorTagModifier = fromJust . stripPrefix "Corrector"
+ } ''CorrectorState
+
+instance Universe CorrectorState where universe = universeDef
+instance Finite CorrectorState
+
+instance PathPiece CorrectorState where
+ toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map toLower . unsafeTail . splitCamel])
+ fromPathPiece = finiteFromPathPiece
+
+derivePersistField "CorrectorState"
+
+
+data AuthenticationMode = AuthLDAP
+ | AuthPWHash { authPWHash :: Text }
+ deriving (Eq, Ord, Read, Show)
+
+deriveJSON defaultOptions
+ { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+ , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+ , sumEncoding = UntaggedValue
+ } ''AuthenticationMode
+
+derivePersistFieldJSON ''AuthenticationMode
+
+
+derivePersistFieldJSON ''Value
+
+
+-- Type synonyms
+
+type SchoolName = CI Text
+type SchoolShorthand = CI Text
+type CourseName = CI Text
+type CourseShorthand = CI Text
+type SheetName = CI Text
+type UserEmail = CI Text
+
+type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/JSON.hs
new file mode 100644
index 000000000..655c95294
--- /dev/null
+++ b/src/Model/Types/JSON.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+
+module Model.Types.JSON
+ ( derivePersistFieldJSON
+ ) where
+
+import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
+import Data.List (foldl)
+import Database.Persist.Sql
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text.Encoding as Text
+
+import qualified Data.Aeson as JSON
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
+
+
+derivePersistFieldJSON :: Name -> DecsQ
+derivePersistFieldJSON n = do
+ DatatypeInfo{..} <- reifyDatatype n
+ vars <- forM datatypeVars (const $ newName "a")
+ let t = foldl (\t n -> t `appT` varT n) (conT n) vars
+ iCxt
+ | null vars = cxt []
+ | otherwise = cxt [[t|ToJSON|] `appT` t, [t|FromJSON|] `appT` t]
+ sqlCxt
+ | null vars = cxt []
+ | otherwise = cxt [[t|PersistField|] `appT` t]
+ sequence
+ [ instanceD iCxt ([t|PersistField|] `appT` t)
+ [ funD (mkName "toPersistValue")
+ [ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) []
+ ]
+ , funD (mkName "fromPersistValue")
+ [ do
+ bs <- newName "bs"
+ clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
+ , do
+ bs <- newName "bs"
+ clause [[p|PersistByteString $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
+ , do
+ t <- newName "t"
+ clause [[p|PersistText $(varP t)|]] (normalB [e|first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 $(varE t)|]) []
+ , clause [wildP] (normalB [e|Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"|]) []
+ ]
+ ]
+ , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
+ [ funD (mkName "sqlType")
+ [ clause [wildP] (normalB [e|SqlOther "json"|]) []
+ ]
+ ]
+ ]
diff --git a/src/Notifications.hs b/src/Notifications.hs
deleted file mode 100644
index 7dd63ad3f..000000000
--- a/src/Notifications.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude
- , RecordWildCards
- , TemplateHaskell
- , OverloadedStrings
- , FlexibleContexts
- , ViewPatterns
- , TypeFamilies
- , DeriveGeneric
- , DeriveDataTypeable
- #-}
-
-module Notifications
- ( handleNotifications
- ) where
-
-import Import
-
-import Data.Conduit.TMChan
-import qualified Data.Conduit.List as C
-
-import Data.Aeson (fromJSON, Result(..))
-import Database.Persist.Sql (rawExecute, fromSqlKey)
-
-
-data NotificationQueueException = QNInvalid QueuedNotification
- | QNLocked QueuedNotificationId UUID UTCTime
- | QNNonexistant QueuedNotificationId
- deriving (Read, Show, Eq, Generic, Typeable)
-
-instance Exception NotificationQueueException
-
-
-handleNotifications :: UniWorX -> IO ()
-handleNotifications foundation@UniWorX{..} = unsafeHandler foundation . bracket_ logStart logStop . runConduit $ sourceTMChan appNotificationCtl .| handleNotifications'
- where
- logStart = $(logDebugS) "Notifications" "Started"
- logStop = $(logDebugS) "Notifications" "Shutting down"
-
-handleNotifications' :: Sink NotificationCtl Handler ()
-handleNotifications' = C.mapM_ $ void . handleAny ($(logErrorS) "Notifications" . tshow) . handleCmd
- where
- handleQueueException :: MonadLogger m => NotificationQueueException -> m ()
- handleQueueException (QNInvalid qn) = $(logWarnS) "Notifications" $ "Invalid QueuedNotification: " ++ tshow qn
- handleQueueException (QNNonexistant qnId) = $(logInfoS) "Notifications" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey qnId)
- handleQueueException (QNLocked qnId lInstance lTime) = $(logDebugS) "Notifications" $ "Saw locked QueuedNotification: " ++ tshow (qnId, lInstance, lTime)
-
- handleCmd NCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedNotificationCreated ] .| C.mapM_ cmdSend
- handleCmd (NCtlSend qnId) = handle handleQueueException . (`finally` qnUnlock qnId) $ do
- qn@QueuedNotification{..} <- qnLock qnId
-
- let
- content :: Notification
- Success content = fromJSON queuedNotificationContent
-
- $(logDebugS) "Notifications" $ "Would send: " <> tshow (queuedNotificationRecipient, content) -- FIXME
-
- runDB $ delete qnId
-
-qnLock :: QueuedNotificationId -> Handler QueuedNotification
-qnLock qnId = runDB $ do
- rawExecute "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE" []
- qn@QueuedNotification{..} <- maybe (throwM $ QNNonexistant qnId) return =<< get qnId
- maybe (return ()) throwM $ QNLocked <$> pure qnId <*> queuedNotificationLockInstance <*> queuedNotificationLockTime
- unless ((fromJSON queuedNotificationContent :: Result Notification) /= mempty) . throwM $ QNInvalid qn
- instanceID <- getsYesod appInstanceID
- now <- liftIO getCurrentTime
- updateGet qnId [ QueuedNotificationLockInstance =. Just instanceID
- , QueuedNotificationLockTime =. Just now
- ]
-
-qnUnlock :: QueuedNotificationId -> Handler ()
-qnUnlock qnId = runDB $ update qnId [ QueuedNotificationLockInstance =. Nothing
- , QueuedNotificationLockTime =. Nothing
- ]
-
-
-cmdSend :: ( MonadHandler m
- , HandlerSite m ~ UniWorX
- ) => QueuedNotificationId -> m ()
-cmdSend (NCtlSend -> cmd) = do
- chan <- getsYesod appNotificationCtl
- liftIO . atomically $ writeTMChan chan cmd
diff --git a/src/Settings.hs b/src/Settings.hs
index 97d582904..0fa14a225 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -3,6 +3,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Settings are centralized, as much as possible, into this file. This
-- includes database connection settings, static file locations, etc.
-- In addition, you can configure a number of different aspects of Yesod
@@ -14,6 +16,8 @@ import ClassyPrelude.Yesod
import qualified Control.Exception as Exception
import Data.Aeson (Result (..), fromJSON, withObject,
(.!=), (.:?))
+import qualified Data.Aeson.Types as Aeson
+import Data.Aeson.TH
import Data.FileEmbed (embedFile)
import Data.Yaml (decodeEither')
import Database.Persist.Postgresql (PostgresConf)
@@ -23,6 +27,19 @@ import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
import Yesod.Default.Util (WidgetFileSettings,
widgetFileNoReload,
widgetFileReload)
+import qualified Yesod.Auth.Util.PasswordStore as PWStore
+
+import qualified Data.Text.Encoding as Text
+
+import qualified Ldap.Client as Ldap
+
+import Utils hiding (MessageClass(..))
+import Control.Lens
+
+import Data.Maybe (fromJust)
+import qualified Data.Char as Char
+
+import Model
-- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files,
@@ -32,6 +49,8 @@ data AppSettings = AppSettings
-- ^ Directory from which to serve static files.
, appDatabaseConf :: PostgresConf
-- ^ Configuration settings for accessing the database.
+ , appLdapConf :: Maybe LdapConf
+ -- ^ Configuration settings for accessing the LDAP-directory
, appRoot :: Maybe Text
-- ^ Base for all generated URLs. If @Nothing@, determined
-- from the request headers.
@@ -43,11 +62,6 @@ data AppSettings = AppSettings
-- ^ Get the IP address from the header when logging. Useful when sitting
-- behind a reverse proxy.
- , appLDAPURI :: String
- , appLDAPDN :: String
- , appLDAPPw :: String
- , appLDAPBaseName :: Maybe String
-
, appDetailedRequestLogging :: Bool
-- ^ Use detailed request logging system
, appShouldLogAll :: Bool
@@ -58,21 +72,80 @@ data AppSettings = AppSettings
-- ^ Assume that files in the static dir may change after compilation
, appSkipCombining :: Bool
-- ^ Perform no stylesheet/script combining
-
- , appDefaultFavourites :: Int
- -- ^ Initial Value for remembered Favourites
-
- -- Example app-specific configuration values.
- , appCopyright :: Text
- -- ^ Copyright text to appear in the footer of the page
- , appAnalytics :: Maybe Text
- -- ^ Google Analytics code
- , appCryptoIDKeyFile :: FilePath
- , appInstanceIDFile :: Maybe FilePath
-
, appAuthDummyLogin :: Bool
-- ^ Indicate if auth dummy login should be enabled.
+ , appAllowDeprecated :: Bool
+ -- ^ Indicate if deprecated routes are accessible for everyone
+ , appMinimumLogLevel :: LogLevel
+
+ , appUserDefaults :: UserDefaultConf
+ , appAuthPWHash :: PWHashConf
+
+ , appCryptoIDKeyFile :: FilePath
+ , appInstanceIDFile :: Maybe FilePath
}
+
+data UserDefaultConf = UserDefaultConf
+ { userDefaultTheme :: Theme
+ , userDefaultMaxFavourites :: Int
+ , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
+ , userDefaultDownloadFiles :: Bool
+ }
+
+data PWHashConf = PWHashConf
+ { pwHashAlgorithm :: PWHashAlgorithm
+ , pwHashStrength :: Int
+ }
+
+instance FromJSON PWHashConf where
+ parseJSON = withObject "PWHashConf" $ \o -> do
+ pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text)
+ pwHashAlgorithm <- if
+ | pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1
+ | pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2
+ | otherwise -> fail "Unsupported hash algorithm"
+ pwHashStrength <- o .: "strength"
+
+ return PWHashConf{..}
+
+data LdapConf = LdapConf
+ { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
+ , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
+ , ldapBase :: Ldap.Dn
+ , ldapScope :: Ldap.Scope
+ , ldapTimeout :: Int32
+ }
+
+deriveFromJSON defaultOptions ''Ldap.Scope
+deriveFromJSON defaultOptions
+ { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+ } ''UserDefaultConf
+
+instance FromJSON LdapConf where
+ parseJSON = withObject "LdapConf" $ \o -> do
+ ldapTls <- o .:? "tls"
+ tlsSettings <- case ldapTls :: Maybe String of
+ Just spec
+ | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings
+ | spec == "default" -> return $ Just Ldap.defaultTlsSettings
+ | null spec -> return Nothing
+ Nothing -> return Nothing
+ _otherwise -> fail "Could not parse LDAP TLSSettings"
+ ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .: "host"
+ ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
+ ldapDn <- Ldap.Dn <$> o .: "user"
+ ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .: "pass"
+ ldapBase <- Ldap.Dn <$> o .: "baseDN"
+ ldapScope <- o .: "scope"
+ ldapTimeout <- o .: "timeout"
+ return LdapConf{..}
+
+deriveFromJSON
+ defaultOptions
+ { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
+ , sumEncoding = UntaggedValue
+ }
+ ''LogLevel
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
@@ -84,29 +157,30 @@ instance FromJSON AppSettings where
#endif
appStaticDir <- o .: "static-dir"
appDatabaseConf <- o .: "database"
+ let nonEmptyHost LdapConf{..} = case ldapHost of
+ Ldap.Tls host _ -> not $ null host
+ Ldap.Plain host -> not $ null host
+ appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host"
appPort <- o .: "port"
appIpFromHeader <- o .: "ip-from-header"
- ( appLDAPURI, appLDAPDN, appLDAPPw, appLDAPBaseName )
- <- (=<< o .: "ldap") . withObject "LDAP" $ \obj -> (,,,) <$> obj .: "uri" <*> obj .: "dn" <*> obj .: "password" <*> obj .:? "basename"
-
appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
+ appMinimumLogLevel <- o .: "minimum-log-level"
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
appMutableStatic <- o .:? "mutable-static" .!= defaultDev
appSkipCombining <- o .:? "skip-combining" .!= defaultDev
+ appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
+ appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
- appDefaultFavourites <- o .: "userDefaultFavourites"
+ appUserDefaults <- o .: "user-defaults"
+ appAuthPWHash <- o .: "auth-pw-hash"
- appCopyright <- o .: "copyright"
- appAnalytics <- o .:? "analytics"
appCryptoIDKeyFile <- o .: "cryptoid-keyfile"
appInstanceIDFile <- o .:? "instance-idfile"
- appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
-
return AppSettings {..}
-- | Settings for 'widgetFile', such as which template languages to support and
diff --git a/src/Utils.hs b/src/Utils.hs
index a1816cb71..08343ec80 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -1,7 +1,13 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
module Utils
( module Utils
@@ -9,18 +15,93 @@ module Utils
import ClassyPrelude.Yesod
+-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
+import Data.Foldable as Fold hiding (length)
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
import Utils.DB as Utils
-import Utils.Common as Utils
+import Utils.TH as Utils
+import Utils.DateTime as Utils
+import Utils.PathPiece as Utils
+import Utils.Message as Utils
+
import Text.Blaze (Markup, ToMarkup)
+import Data.Char (isDigit)
+import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
+import Numeric (showFFloat)
+
+import Control.Lens
+import Data.Set (Set)
+import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
-import qualified Data.List as List
+-- import qualified Data.List as List
+import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Catch
+
+
+import qualified Database.Esqueleto as E (Value, unValue)
+
+import Language.Haskell.TH
+import Instances.TH.Lift ()
+
+import Text.Shakespeare.Text (st)
+
+
+
+-----------
+-- Yesod --
+-----------
+
+newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) }
+
+getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
+getMsgRenderer = do
+ mr <- getMessageRender
+ return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
+
+
+instance Monad FormResult where
+ FormMissing >>= _ = FormMissing
+ (FormFailure errs) >>= _ = FormFailure errs
+ (FormSuccess a) >>= f = f a
+
+guardAuthResult :: MonadHandler m => AuthResult -> m ()
+guardAuthResult AuthenticationRequired = notAuthenticated
+guardAuthResult (Unauthorized t) = permissionDenied t
+guardAuthResult Authorized = return ()
+
+data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route
+ deriving (Eq, Ord, Typeable, Show)
+instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)
+
+unsupportedAuthPredicate :: ExpQ
+unsupportedAuthPredicate = do
+ logFunc <- logErrorS
+ [e| \tag route -> do
+ $(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|]
+ unauthorizedI (UnsupportedAuthPredicate tag route)
+ |]
+
+
+
+---------------------
+-- Text and String --
+---------------------
tickmark :: IsString a => a
tickmark = fromString "✔"
+-- Avoid annoying warnings:
+tickmarkS :: String
+tickmarkS = tickmark
+tickmarkT :: Text
+tickmarkT = tickmark
text2Html :: Text -> Html
text2Html = toHtml -- prevents ambiguous types
@@ -29,28 +110,327 @@ toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
a -> WidgetT site m ()
toWgt = toWidget . toHtml
+-- Convenience Functions to avoid type signatures:
text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
Text -> WidgetT site m ()
text2widget t = [whamlet|#{t}|]
+citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+ (CI Text) -> WidgetT site m ()
+citext2widget t = [whamlet|#{CI.original t}|]
+
str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
String -> WidgetT site m ()
str2widget s = [whamlet|#{s}|]
+display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) =>
+ a -> WidgetT site m ()
+display2widget = text2widget . display
-withFragment :: ( Monad m
- ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
+withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
+
+-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
+{- (not so sure we really want to get rid of display?!) DEPRECATED display "Create RenderMessage Instances instead!" -}
+class DisplayAble a where
+ display :: a -> Text
+ -- Default definitions for types belonging to Show (allows empty instance declarations)
+ default display :: Show a => a -> Text
+ display = pack . show
+
+instance DisplayAble Text where
+ display = id
+
+instance DisplayAble String where
+ display = pack
+
+instance DisplayAble Int
+instance DisplayAble Int64
+instance DisplayAble Integer
+
+instance DisplayAble Rational where
+ display r = showFFloat (Just 2) (rat2float r) ""
+ & pack
+ & dropWhileEnd ('0'==)
+ & dropWhileEnd ('.'==)
+ where
+ rat2float :: Rational -> Double
+ rat2float = fromRational
+
+instance DisplayAble a => DisplayAble (Maybe a) where
+ display Nothing = ""
+ display (Just x) = display x
+
+instance DisplayAble a => DisplayAble (E.Value a) where
+ display = display . E.unValue
+
+instance DisplayAble a => DisplayAble (CI a) where
+ display = display . CI.original
+
+{- We do not want DisplayAble for every Show-Class:
+ We want to explicitly verify that the resulting text can be displayed to the User!
+ For example: UTCTime values were shown without proper format rendering!
+instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
+ display = pack . show
+-}
+
+textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
+textPercent x = lz <> (pack $ show rx) <> "%"
+ where
+ round' :: Double -> Int -- avoids annoying warning
+ round' = round
+ rx :: Double
+ rx = fromIntegral (round' $ 1000.0*x) / 10.0
+ lz = if rx < 10.0 then "0" else ""
+
+stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
+stepTextCounterCI = CI.map stepTextCounter
+
+stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes
+stepTextCounter text
+ | (Just i) <- readMay number =
+ let iplus1 = tshow (succ i :: Int)
+ zeroip = justifyRight (length number) '0' iplus1
+ in prefix <> zeroip <> suffix
+ | otherwise = text
+ where -- no splitWhile nor findEnd in Data.Text
+ suffix = takeWhileEnd (not . isDigit) text
+ number = takeWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
+ prefix = dropWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
+
+-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)"
+-- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"]
+
+
+------------
+-- Tuples --
+------------
+
+fst3 :: (a,b,c) -> a
+fst3 (x,_,_) = x
+snd3 :: (a,b,c) -> b
+snd3 (_,y,_) = y
+trd3 :: (a,b,c) -> c
+trd3 (_,_,z) = z
+
+-- Further projections are available via TemplateHaskell, defined in Utils.Common:
+-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
+-- snd3 = $(projNI 3 2)
+
+
+
-----------
--- Maybe --
+-- Lists --
-----------
-whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
-whenIsJust (Just x) f = f x
-whenIsJust Nothing _ = return ()
+
+-- notNull = not . null
+
+lastMaybe :: [a] -> Maybe a
+lastMaybe [] = Nothing
+lastMaybe [h] = Just h
+lastMaybe (_:t) = lastMaybe t
+
+lastMaybe' :: [a] -> Maybe a
+lastMaybe' l = fmap snd $ l ^? _Snoc
+
+
+mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
+mergeAttrs = mergeAttrs' `on` sort
+ where
+ special = [ ("class", \v1 v2 -> v1 <> " " <> v2)
+ ]
+
+ mergeAttrs' (x1@(n1, v1):xs1) (x2@(n2, v2):xs2)
+ | Just merge <- lookup n1 special
+ , n2 == n1
+ = mergeAttrs' ((n1, merge v1 v2) : xs1) xs2
+ | Just _ <- lookup n1 special
+ , n1 < n2
+ = x2 : mergeAttrs' (x1:xs1) xs2
+ | otherwise = x1 : mergeAttrs' xs1 (x2:xs2)
+ mergeAttrs' [] xs2 = xs2
+ mergeAttrs' xs1 [] = xs1
----------
-- Maps --
----------
+
+infixl 5 !!!
+
+
+(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
+(!!!) m k = (fromMaybe mempty) $ Map.lookup k m
+
+groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
+groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l]
+
+partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
+partMap = Map.fromListWith mappend
+
+invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
+invertMap = groupMap . map swap . Map.toList
+
+
+
+-----------
+-- Maybe --
+-----------
+
+toMaybe :: Bool -> a -> Maybe a
+toMaybe True = Just
+toMaybe False = const Nothing
+
+toNothing :: a -> Maybe b
+toNothing = const Nothing
+
+toNothingS :: String -> Maybe b
+toNothingS = const Nothing
+
+maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
+maybeAdd (Just x) (Just y) = Just (x + y)
+maybeAdd Nothing y = y
+maybeAdd x Nothing = x
+
+maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
+maybeEmpty (Just x) f = f x
+maybeEmpty Nothing _ = mempty
+
+whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenIsJust (Just x) f = f x
+whenIsJust Nothing _ = return ()
+
+ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
+ifMaybeM Nothing dft _ = return dft
+ifMaybeM (Just x) _ act = act x
+
+maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
+maybeM dft act mb = mb >>= maybe dft act
+
+maybeT :: Monad m => m a -> MaybeT m a -> m a
+maybeT x m = runMaybeT m >>= maybe x return
+
+catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
+catchIfMaybeT p act = catchIf p (lift act) (const mzero)
+
+mcons :: Maybe a -> [a] -> [a]
+mcons Nothing xs = xs
+mcons (Just x) xs = x:xs
+
+newtype NTop a = NTop a -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
+
+instance Eq a => Eq (NTop (Maybe a)) where
+ (NTop x) == (NTop y) = x == y
+
+instance Ord a => Ord (NTop (Maybe a)) where
+ compare (NTop Nothing) (NTop Nothing) = EQ
+ compare (NTop Nothing) _ = GT
+ compare _ (NTop Nothing) = LT
+ compare (NTop (Just x)) (NTop (Just y)) = compare x y
+
+
+
+------------
+-- Either --
+------------
+
+maybeLeft :: Either a b -> Maybe a
+maybeLeft (Left a) = Just a
+maybeLeft _ = Nothing
+
+maybeRight :: Either a b -> Maybe b
+maybeRight (Right b) = Just b
+maybeRight _ = Nothing
+
+whenIsLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
+whenIsLeft (Left x) f = f x
+whenIsLeft (Right _) _ = return ()
+
+whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m ()
+whenIsRight (Right x) f = f x
+whenIsRight (Left _) _ = return ()
+
+
+---------------
+-- Exception --
+---------------
+
+maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
+maybeExceptT err act = lift act >>= maybe (throwE err) return
+
+maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b
+maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
+
+whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
+whenExceptT b err = when b $ throwE err
+
+whenMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
+whenMExceptT b err = when b $ lift err >>= throwE
+
+guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
+guardExceptT b err = unless b $ throwE err
+
+guardMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
+guardMExceptT b err = unless b $ lift err >>= throwE
+
+exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
+exceptT f g = either f g <=< runExceptT
+
+catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
+catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
+
+
+
+------------
+-- Monads --
+------------
+
+shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
+shortCircuitM sc mx my bop = do
+ x <- mx
+ case sc x of
+ True -> return x
+ False -> bop <$> pure x <*> my
+
+
+guardM :: MonadPlus m => m Bool -> m ()
+guardM f = guard =<< f
+
+assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
+assertM f x = x >>= assertM' f
+
+assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
+assertM' f x = x <$ guard (f x)
+
+-- Some Utility Functions from Agda.Utils.Monad
+-- | Monadic if-then-else.
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM c m m' =
+ do b <- c
+ if b then m else m'
+
+-- | @ifNotM mc = ifM (not <$> mc)@
+ifNotM :: Monad m => m Bool -> m a -> m a -> m a
+ifNotM c = flip $ ifM c
+
+-- | Lazy monadic conjunction.
+and2M :: Monad m => m Bool -> m Bool -> m Bool
+and2M ma mb = ifM ma mb (return False)
+
+andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+andM = Fold.foldr and2M (return True)
+
+allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+allM xs f = andM $ fmap f xs
+
+-- | Lazy monadic disjunction.
+or2M :: Monad m => m Bool -> m Bool -> m Bool
+or2M ma mb = ifM ma (return True) mb
+
+orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+orM = Fold.foldr or2M (return False)
+
+anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+anyM xs f = orM $ fmap f xs
diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs
deleted file mode 100644
index 7ef941d4d..000000000
--- a/src/Utils/Common.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module Utils.Common where
--- Common Utility Functions
-
-import Language.Haskell.TH
-
-
-------------
--- Tuples --
-------------
-
-fst3 :: (a,b,c) -> a
-fst3 (x,_,_) = x
-snd3 :: (a,b,c) -> b
-snd3 (_,y,_) = y
-trd3 :: (a,b,c) -> c
-trd3 (_,_,z) = z
-
-projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2) --ghci -fth
--- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
-projNI n i = lamE [pat] rhs
- where pat = tupP (map varP xs)
- rhs = varE (xs !! (i - 1))
- xs = [ mkName $ "x" ++ show j | j <- [1..n] ]
-
-
----------------
--- Functions --
----------------
-
-permuteFun :: [Int] -> ExpQ -- generic permutation of function arguments, i.e. $(permuteFun [2,1]) == flip
-permuteFun perm = lamE pat rhs
- where pat = map varP $ fn:xs
- rhs = foldl appE (varE fn) $ map varE ps
--- rhs = appE (varE fn) (varE $ xs!!1)
- ln = length perm
- xs = [ mkName $ "x" ++ show j | j <- [1..ln] ]
- ps = [ xs !! (j-1) | j <- perm ]
- fn = mkName "fn"
-
-altFun :: [Int] -> ExpQ -- generic permutation/repetition of function arguments, i.e. $(permuteFun [2,1]) == flip
-altFun perm = lamE pat rhs
- where pat = map varP $ fn:xs
- rhs = foldl appE (varE fn) $ map varE ps
--- rhs = appE (varE fn) (varE $ xs!!1)
- mx = maximum perm
- xs = [ mkName $ "x" ++ show j | j <- [1..mx] ]
- ps = [ xs !! (j-1) | j <- perm ]
- fn = mkName "fn"
-
diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs
index 744cbe85a..380bb8b2a 100644
--- a/src/Utils/DB.hs
+++ b/src/Utils/DB.hs
@@ -10,11 +10,19 @@ import ClassyPrelude.Yesod
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Database.Esqueleto as E
+-- import Database.Persist -- currently not needed here
-import Database.Persist
--- getKeyBy :: PersistEntity val => Unique val -> ReaderT backend0 m0 (Maybe (Entity val))
--- getKeyBy :: Unique a -> YesodDB site (Key a)
+
+emptyOrIn :: PersistField typ =>
+ E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
+emptyOrIn criterion testSet
+ | Set.null testSet = E.val True
+ | otherwise = criterion `E.in_` E.valList (Set.toList testSet)
+
entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
@@ -27,8 +35,15 @@ getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity
=> Unique record -> ReaderT backend m (Key record)
getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
+existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
+ => Unique record -> ReaderT backend m Bool
+existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record
-myReplaceUnique
+existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
+ => Key record -> ReaderT backend m Bool
+existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
+
+myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq record which is not needed anyway)
:: (MonadIO m
,Eq (Unique record)
,PersistRecordBackend record backend
diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs
new file mode 100644
index 000000000..1b82dbe12
--- /dev/null
+++ b/src/Utils/DateTime.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE NoImplicitPrelude
+ , TemplateHaskell
+ , QuasiQuotes
+ , StandaloneDeriving
+ , DeriveLift
+ #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Utils.DateTime
+ ( timeLocaleMap
+ , TimeLocale(..)
+ , currentYear
+ , module Data.Time.Zones
+ , module Data.Time.Zones.TH
+ ) where
+
+import ClassyPrelude.Yesod hiding (lift)
+import System.Locale.Read
+
+import Data.Time (TimeZone(..), TimeLocale(..))
+import Data.Time.Zones (TZ)
+import Data.Time.Zones.TH (includeSystemTZ)
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift(..))
+import Instances.TH.Lift ()
+
+deriving instance Lift TimeZone
+deriving instance Lift TimeLocale
+
+
+-- $(timeLocaleMap _) :: [Lang] -> TimeLocale
+timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
+ -> ExpQ
+timeLocaleMap [] = fail "Need at least one (language, locale)-pair"
+timeLocaleMap extra@((_, defLocale):_) = do
+ localeMap <- newName "localeMap"
+
+ let
+ localeMap' = funD localeMap $ map matchLang extra ++ [reduceLangList, defaultLang]
+
+ defaultLang :: ClauseQ
+ defaultLang =
+ clause [listP []] (normalB $ localeExp defLocale) []
+
+ reduceLangList :: ClauseQ
+ reduceLangList = do
+ ls <- newName "ls"
+ clause [[p|(_ : $(varP ls))|]] (normalB [e|$(varE localeMap) $(varE ls)|]) []
+
+ matchLang :: (Lang, String) -> ClauseQ
+ matchLang (lang, localeStr) = do
+ lang' <- newName "lang"
+ clause [[p|($(varP lang') : _)|]] (guardedB [(,) <$> normalG [e|$(varE lang') == lang|] <*> localeExp localeStr]) []
+
+ localeExp :: String -> ExpQ
+ localeExp = lift <=< runIO . getLocale . Just
+
+ letE [localeMap'] (varE localeMap)
+
+currentYear :: ExpQ
+currentYear = do
+ now <- runIO getCurrentTime
+ let (year, _, _) = toGregorian $ utctDay now
+ [e|year|]
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
new file mode 100644
index 000000000..939169e9b
--- /dev/null
+++ b/src/Utils/Form.hs
@@ -0,0 +1,218 @@
+{-# LANGUAGE NoImplicitPrelude
+ , TemplateHaskell
+ , ViewPatterns
+ , OverloadedStrings
+ , QuasiQuotes
+ , TemplateHaskell
+ , MultiParamTypeClasses
+ , TypeFamilies
+ , FlexibleContexts
+ , NamedFieldPuns
+ , ScopedTypeVariables
+#-}
+
+module Utils.Form where
+
+import ClassyPrelude.Yesod
+import Settings
+
+import qualified Text.Blaze.Internal as Blaze (null)
+import qualified Data.Text as T
+import qualified Data.Char as Char
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Web.PathPieces
+
+-------------------
+-- Form Renderer --
+-------------------
+
+-- | Use this type to pass information to the form template
+data FormLayout = FormStandard
+
+renderAForm :: Monad m => FormLayout -> FormRender m a
+renderAForm formLayout aform fragment = do
+ (res, (($ []) -> views)) <- aFormToForm aform
+ let widget = $(widgetFile "widgets/form")
+ return (res, widget)
+
+--------------------
+-- Field Settings --
+--------------------
+
+fsl :: Text -> FieldSettings site
+fsl lbl =
+ FieldSettings { fsLabel = (SomeMessage lbl)
+ , fsTooltip = Nothing
+ , fsId = Nothing
+ , fsName = Nothing
+ , fsAttrs = []
+ }
+
+fslI :: RenderMessage site msg => msg -> FieldSettings site
+fslI lbl =
+ FieldSettings { fsLabel = (SomeMessage lbl)
+ , fsTooltip = Nothing
+ , fsId = Nothing
+ , fsName = Nothing
+ , fsAttrs = []
+ }
+
+fslp :: Text -> Text -> FieldSettings site
+fslp lbl placeholder =
+ FieldSettings { fsLabel = (SomeMessage lbl)
+ , fsTooltip = Nothing
+ , fsId = Nothing
+ , fsName = Nothing
+ , fsAttrs = [("placeholder", placeholder)]
+ }
+
+fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
+fslpI lbl placeholder =
+ FieldSettings { fsLabel = (SomeMessage lbl)
+ , fsTooltip = Nothing
+ , fsId = Nothing
+ , fsName = Nothing
+ , fsAttrs = [("placeholder", placeholder)]
+ }
+
+addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
+addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
+ where
+ newAttrs :: [(Text,Text)] -> [(Text,Text)]
+ newAttrs [] = [(attr,valu)]
+ newAttrs (p@(a,v):t)
+ | attr==a = (a,T.append valu $ cons ' ' v):t
+ | otherwise = p:(newAttrs t)
+
+addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
+addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
+ where
+ newAttrs :: [(Text,Text)] -> [(Text,Text)]
+ newAttrs [] = [(attr,T.intercalate " " valus)]
+ newAttrs (p@(a,v):t)
+ | attr==a = (a,T.intercalate " " (v:valus)):t
+ | otherwise = p:(newAttrs t)
+
+addClass :: Text -> FieldSettings site -> FieldSettings site
+addClass = addAttr "class"
+
+addClasses :: [Text] -> FieldSettings site -> FieldSettings site
+addClasses = addAttrs "class"
+
+addName :: Text -> FieldSettings site -> FieldSettings site
+addName nm fs = fs { fsName = Just nm }
+
+addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
+addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
+
+addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
+addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
+
+
+setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
+setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
+
+setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
+setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
+
+setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
+setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
+
+addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => Field m a -> WidgetT (HandlerSite m) IO vals -> Field m a
+addDatalist field mValues = field
+ { fieldView = \fId fName fAttrs fRes fReq -> do
+ listId <- newIdent
+ values <- map toPathPiece . otoList <$> mValues
+ fieldView field fId fName (("list", listId) : fAttrs) fRes fReq
+ [whamlet|
+ $newline never
+