Aggressively refactor Model.Types

src/Data/Aeson/Types/Instances.hs

@@ -14,9 +14,13 @@ import Data.Binary (Binary)
 import Data.HashMap.Strict.Instances ()
 import Data.Vector.Instances ()
 
+import Model.Types.TH.JSON (derivePersistFieldJSON)
+
 
 instance MonadThrow Parser where
   throwM = fail . show
 
-
 instance Binary Value
+
+
+derivePersistFieldJSON ''Value

src/Data/Time/Calendar/Instances.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Time.Calendar.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+deriving newtype instance Hashable Day
+
+instance Binary Day where
+  get = ModifiedJulianDay <$> Binary.get
+  put = Binary.put . toModifiedJulianDay
+

src/Data/Time/Clock/Instances.hs

@@ -11,14 +11,17 @@ import Data.Time.Clock
 import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
+import Data.Time.Calendar.Instances ()
+
+
+instance Hashable DiffTime where
+  hashWithSalt s = hashWithSalt s . toRational
+
 
 deriving instance Generic UTCTime
+instance Hashable UTCTime
 
 
-instance Binary Day where
-  get = ModifiedJulianDay <$> Binary.get
-  put = Binary.put . toModifiedJulianDay
-
 instance Binary DiffTime where
   get = fromRational <$> Binary.get
   put = Binary.put . toRational

src/Data/Time/Format/Instances.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS -fno-warn-orphans #-}
+
+module Data.Time.Format.Instances
+  (
+  ) where
+
+import qualified Language.Haskell.TH.Syntax as TH
+
+import Data.Time.Format
+
+import Data.Time.LocalTime.Instances ()
+
+
+deriving instance TH.Lift TimeLocale

src/Data/Time/LocalTime/Instances.hs

@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Time.LocalTime.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Time.LocalTime
+
+import Data.Binary (Binary)
+
+import qualified Language.Haskell.TH.Syntax as TH
+
+
+deriving instance Generic TimeOfDay
+deriving instance Typeable TimeOfDay
+
+instance Hashable TimeOfDay
+instance Binary TimeOfDay
+
+
+deriving instance TH.Lift TimeZone

src/Data/UUID/Instances.hs

@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.UUID.Instances
+  () where
+
+import ClassyPrelude
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+
+import Database.Persist.Sql
+import Web.PathPieces
+  
+
+instance PathPiece UUID where
+  fromPathPiece = UUID.fromString . unpack
+  toPathPiece = pack . UUID.toString
+
+instance PersistField UUID where
+  toPersistValue = PersistDbSpecific . UUID.toASCIIBytes
+
+  fromPersistValue (PersistText t)        = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t
+  fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
+  fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
+  fromPersistValue  x                     = Left $ "Expected UUID, received: " <> tshow x
+
+instance PersistFieldSql UUID where
+  sqlType _ = SqlOther "uuid"

src/Database/Persist/Class/Instances.hs

@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Persist.Class.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Database.Persist.Class
+import Database.Persist.Types.Instances ()
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+
+instance PersistEntity record => Hashable (Key record) where
+  hashWithSalt s = hashWithSalt s . toPersistValue
+
+instance PersistEntity record => Binary (Key record) where
+  put = Binary.put . toPersistValue
+  putList = Binary.putList . map toPersistValue
+  get = either (fail . unpack) return . fromPersistValue =<< Binary.get

src/Database/Persist/Sql/Instances.hs

@@ -1,33 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Database.Persist.Sql.Instances
-  (
-  ) where
-
-import ClassyPrelude.Yesod
-
-import Data.Binary (Binary)
-import qualified Data.Binary as B
-
-import Database.Persist.Sql
-
-
-instance Binary (BackendKey SqlWriteBackend) where
-  put = B.put . unSqlWriteBackendKey
-  putList = B.putList . map unSqlWriteBackendKey
-  get = SqlWriteBackendKey <$> B.get
-instance Binary (BackendKey SqlReadBackend) where
-  put = B.put . unSqlReadBackendKey
-  putList = B.putList . map unSqlReadBackendKey
-  get = SqlReadBackendKey <$> B.get
-instance Binary (BackendKey SqlBackend) where
-  put = B.put . unSqlBackendKey
-  putList = B.putList . map unSqlBackendKey
-  get = SqlBackendKey <$> B.get
-  
-
-instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Binary (Key record) where
-  put = B.put . fromSqlKey
-  putList = B.putList . map fromSqlKey
-  get = toSqlKey <$> B.get

src/Database/Persist/Types/Instances.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Database.Persist.Types.Instances
@@ -6,7 +5,18 @@ module Database.Persist.Types.Instances
   ) where
 
 import ClassyPrelude
+
 import Database.Persist.Types
 
-instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where
+import Data.Time.Calendar.Instances ()
-  s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal
+import Data.Time.LocalTime.Instances ()
+import Data.Time.Clock.Instances ()
+
+import Data.Binary (Binary)
+
+
+deriving instance Generic PersistValue
+deriving instance Typeable PersistValue
+
+instance Hashable PersistValue
+instance Binary PersistValue

src/Handler/Utils/Communication.hs

@@ -20,9 +20,6 @@ import Data.Map ((!), (!?))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
-import Data.Aeson.TH
-import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
-
 
 data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors
                     | RGTutorialParticipants

src/Handler/Utils/Form/MassInput.hs

@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- tupleBoxCoord
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Handler.Utils.Form.MassInput
@@ -20,8 +20,6 @@ import Utils.Lens
 import Handler.Utils.Form.MassInput.Liveliness
 import Handler.Utils.Form.MassInput.TH
 
-import Data.Aeson hiding (Result(..))
-
 import Algebra.Lattice hiding (join)
 
 import Text.Blaze (Markup)

src/Handler/Utils/Invitations.hs

@@ -32,7 +32,6 @@ import qualified Data.HashSet as HashSet
 
 import Data.Aeson (fromJSON)
 import qualified Data.Aeson as JSON
-import Data.Aeson.TH
 
 import Data.Proxy (Proxy(..))
 import Data.Typeable

src/Handler/Utils/Table/Pagination.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS -fno-warn-orphans #-}
-
 module Handler.Utils.Table.Pagination
   ( module Handler.Utils.Table.Pagination.Types
   , SortColumn(..), SortDirection(..)

src/Import/NoFoundation.hs

@@ -1,109 +1,17 @@
 module Import.NoFoundation
     ( module Import
-    , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
+import Import.NoModel         as Import
 import Model                  as Import
-import Model.Types.JSON       as Import
 import Model.Migration        as Import
 import Model.Rating           as Import
 import Model.Submission       as Import
 import Model.Tokens           as Import
+import Utils.Tokens           as Import
+import Utils.Frontend.Modal   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 Utils.Frontend.Modal   as Import
-import Utils.Frontend.I18n    as Import
-import Utils.DB               as Import
-import Yesod.Core.Json        as Import (provideJson)
-import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
-
-import Language.Haskell.TH.Instances as Import ()
-
-import Utils.Tokens           as Import
-
-
-import Data.Fixed             as Import
 
 import CryptoID               as Import
-import Data.UUID              as Import (UUID)
-
-import Text.Lucius            as Import
-
-import Text.Shakespeare.Text  as Import hiding (text, stext)
-
-import Data.Universe          as Import
-import Data.Universe.TH       as Import
-import Data.Pool              as Import (Pool)
-import Network.HaskellNet.SMTP as Import (SMTPConnection)
-
-import Mail                   as Import
-
-import Data.Data              as Import (Data)
-import Data.Typeable          as Import (Typeable)
-import GHC.Generics           as Import (Generic)
-import GHC.Exts               as Import (IsList)
-
-import Data.Hashable          as Import
-import Data.List.NonEmpty     as Import (NonEmpty(..), nonEmpty)
-import Data.List.NonEmpty.Instances as Import ()
-import Data.NonNull.Instances as Import ()
-import Data.Text.Encoding.Error as Import(UnicodeException(..))
-import Data.Semigroup         as Import (Semigroup)
-import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..), Sum(..))
-import Data.Monoid.Instances  as Import ()
-import Data.Set.Instances     as Import ()
-import Data.HashMap.Strict.Instances as Import ()
-import Data.HashSet.Instances as Import ()
-import Data.Vector.Instances  as Import ()
-import Data.Time.Clock.Instances as Import ()
-
-import Data.Binary            as Import (Binary)
-
-import Control.Monad.Morph    as Import (MFunctor(..))
-
-import Control.Monad.Trans.Resource as Import (ReleaseKey)
-
-import Network.Mail.Mime.Instances as Import ()
-import Yesod.Core.Instances as Import ()
-import Data.Aeson.Types.Instances as Import ()
-
-import Ldap.Client.Pool as Import
-
-import Database.Esqueleto.Instances as Import ()
-import Database.Persist.Sql.Instances as Import ()
-import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
-import Database.Persist.Types.Instances as Import ()
-
-import Numeric.Natural.Instances as Import ()
-import System.Random as Import (Random)
-import Control.Monad.Random.Class as Import (MonadRandom(..))
-
-import Text.Blaze.Instances as Import ()
-import Jose.Jwt.Instances as Import ()
-import Jose.Jwt as Import (Jwt)
-import Web.PathPieces.Instances as Import ()
-
-import Data.Time.Calendar as Import
-import Data.Time.Clock as Import
-import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
-import Time.Types as Import (WeekDay(..))
-
-import Time.Types.Instances as Import ()
-
-import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
-
-import Data.Ratio as Import ((%))
-
-import Network.Mime as Import
-
-import Data.Universe.Instances.Reverse.MonoTraversable ()
-
-
-import Control.Monad.Trans.RWS (RWST)
-
-type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m

src/Import/NoModel.hs

@@ -0,0 +1,105 @@
+module Import.NoModel
+  ( module Import
+  , MForm
+  ) where
+
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
+
+import Model.Types.TH.JSON as Import
+import Model.Types.TH.Wordlist as Import
+
+import Mail                   as Import
+
+import Yesod.Auth             as Import
+import Yesod.Core.Types       as Import (loggerSet)
+import Yesod.Default.Config2  as Import
+import Yesod.Core.Json        as Import (provideJson)
+import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
+
+import Utils                  as Import
+import Utils.Frontend.I18n    as Import
+import Utils.DB               as Import
+
+import Data.Fixed             as Import
+
+import Data.UUID              as Import (UUID)
+
+import Data.CaseInsensitive   as Import (CI, FoldCase(..), foldedCase)
+
+import Text.Lucius            as Import
+import Text.Shakespeare.Text  as Import hiding (text, stext)
+
+import Data.Universe          as Import
+import Data.Universe.TH       as Import
+import Data.Pool              as Import (Pool)
+import Network.HaskellNet.SMTP as Import (SMTPConnection)
+
+import Data.Data              as Import (Data)
+import Data.Typeable          as Import (Typeable)
+import GHC.Generics           as Import (Generic)
+import GHC.Exts               as Import (IsList)
+import Data.Ix                as Import (Ix)
+
+import Data.Hashable          as Import
+import Data.List.NonEmpty     as Import (NonEmpty(..), nonEmpty)
+import Data.Text.Encoding.Error as Import(UnicodeException(..))
+import Data.Semigroup         as Import (Semigroup)
+import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..), Sum(..))
+import Data.Binary            as Import (Binary)
+
+import Numeric.Natural        as Import (Natural)
+import Data.Ratio             as Import ((%))
+
+import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey)
+  
+import Ldap.Client.Pool as Import
+
+import System.Random as Import (Random(..))
+import Control.Monad.Random.Class as Import (MonadRandom(..))
+
+import Control.Monad.Morph    as Import (MFunctor(..))
+import Control.Monad.Trans.Resource as Import (ReleaseKey)
+
+import Jose.Jwt as Import (Jwt)
+
+import Data.Time.Calendar as Import
+import Data.Time.Clock as Import
+import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
+import Time.Types as Import (WeekDay(..))
+
+import Network.Mime as Import
+  
+import Data.Aeson.TH as Import
+import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value)
+
+import Language.Haskell.TH.Instances as Import ()
+import Data.List.NonEmpty.Instances as Import ()
+import Data.NonNull.Instances as Import ()
+import Data.Monoid.Instances  as Import ()
+import Data.Set.Instances     as Import ()
+import Data.HashMap.Strict.Instances as Import ()
+import Data.HashSet.Instances as Import ()
+import Data.Vector.Instances  as Import ()
+import Data.Time.Clock.Instances as Import ()
+import Data.Time.LocalTime.Instances as Import ()
+import Data.Time.Calendar.Instances as Import ()
+import Data.Time.Format.Instances as Import ()
+import Time.Types.Instances as Import ()
+import Network.Mail.Mime.Instances as Import ()
+import Yesod.Core.Instances as Import ()
+import Data.Aeson.Types.Instances as Import ()
+import Database.Esqueleto.Instances as Import ()
+import Numeric.Natural.Instances as Import ()
+import Text.Blaze.Instances as Import ()
+import Jose.Jwt.Instances as Import ()
+import Web.PathPieces.Instances as Import ()
+import Data.Universe.Instances.Reverse.MonoTraversable ()
+import Database.Persist.Class.Instances as Import ()
+import Database.Persist.Types.Instances as Import ()
+import Data.UUID.Instances as Import ()
+import System.FilePath.Instances as Import ()
+
+
+import Control.Monad.Trans.RWS (RWST)
+
+type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m

src/Mail.hs

@@ -35,7 +35,9 @@ module Mail
   , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
   ) where
 
-import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
+import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
+
+import Model.Types.TH.JSON
 
 import Network.Mail.Mime hiding (addPart, addAttachment)
 import qualified Network.Mail.Mime as Mime (addPart)
@@ -159,6 +161,7 @@ instance Default MailLanguages where
 
 instance Hashable MailLanguages
 
+
 data MailContext = MailContext
   { mcLanguages :: MailLanguages
   , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
@@ -506,3 +509,6 @@ setMailSmtpData = do
         in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
     | otherwise
     -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }
+
+
+derivePersistFieldJSON ''MailLanguages

src/Model.hs

@@ -6,7 +6,7 @@ module Model
   , module Cron.Types
   ) where
 
-import ClassyPrelude.Yesod
+import Import.NoModel
 import Database.Persist.Quasi
 import Database.Persist.TH.Directory
 -- import Data.Time
@@ -23,8 +23,6 @@ import Utils.Message (MessageStatus)
 
 import Settings.Cluster (ClusterSettingsKey)
 
-import Data.Binary (Binary)
-
 -- 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:
@@ -38,9 +36,5 @@ deriving instance Eq (Unique Sheet)     -- instance Eq CourseSheet
 deriving instance Eq (Unique Material)  -- instance Eq UniqueMaterial
 deriving instance Eq (Unique Tutorial)  -- instance Eq Tutorial
 
--- Primary keys mentioned in dbtable row-keys must be Binary
--- Automatically generated (i.e. numeric) ids are already taken care of
-deriving instance Binary (Key Term)
-
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Model/Migration/Types.hs

@@ -7,7 +7,7 @@ import Data.Aeson.TH (deriveJSON, defaultOptions)
 import Utils.PathPiece
 
 import qualified Model as Current
-import qualified Model.Types.JSON as Current
+import qualified Model.Types.TH.JSON as Current
 
 import Data.Universe
 

src/Model/Types.hs

@@ -1,72 +1,14 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
-
-
-
 module Model.Types
-  ( module Model.Types
+  ( module Types
-  , module Model.Types.Sheet
-  , module Model.Types.DateTime
-  , module Model.Types.Security
-  , module Model.Types.Misc
-  , module Numeric.Natural
-  , module Mail
-  , module Utils.DateTime
-  , module Data.UUID.Types
   ) where
 
-import ClassyPrelude
+import Model.Types.Common as Types
-import Data.UUID.Types (UUID)
+import Model.Types.Course as Types
-import qualified Data.UUID.Types as UUID
+import Model.Types.DateTime as Types
-import Data.NonNull.Instances ()
+import Model.Types.Exam as Types
-
+import Model.Types.Health as Types
-import Data.Text (Text)
+import Model.Types.Mail as Types
-import qualified Data.Text as Text
+import Model.Types.Security as Types
-import Data.CaseInsensitive (CI)
+import Model.Types.Sheet as Types
-import Data.CaseInsensitive.Instances ()
+import Model.Types.Submission as Types
-
+import Model.Types.Misc as Types
-import Data.Universe.Instances.Reverse ()
-
-import Yesod.Core.Dispatch (PathPiece(..))
-import qualified Yesod.Auth.Util.PasswordStore as PWStore
-import Web.PathPieces
-
-import Mail (MailLanguages(..))
-import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
-import Numeric.Natural
-
-import Model.Types.Sheet
-import Model.Types.DateTime
-import Model.Types.Security
-import Model.Types.Misc
-
-----
--- Just bringing together the different Model.Types submodules.
-
-instance PathPiece UUID where
-  fromPathPiece = UUID.fromString . unpack
-  toPathPiece = pack . UUID.toString
-
-instance {-# OVERLAPS #-} PathMultiPiece FilePath where
-  fromPathMultiPiece = Just . unpack . intercalate "/"
-  toPathMultiPiece = Text.splitOn "/" . pack
-
-
--- Type synonyms
-
-type Email           = Text
-
-type SchoolName      = CI Text
-type SchoolShorthand = CI Text
-type CourseName      = CI Text
-type CourseShorthand = CI Text
-type SheetName       = CI Text
-type MaterialName    = CI Text
-type UserEmail       = CI Email
-type TutorialName    = CI Text
-
-type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
-type InstanceId      = UUID
-type ClusterId       = UUID
-type TokenId         = UUID
-type TermCandidateIncidence = UUID

src/Model/Types/Common.hs

@@ -0,0 +1,29 @@
+module Model.Types.Common
+  ( module Model.Types.Common
+  ) where
+
+import Import.NoModel
+
+import qualified Yesod.Auth.Util.PasswordStore as PWStore
+  
+
+type Count  = Sum Integer
+type Points = Centi
+
+
+type Email           = Text
+
+type SchoolName      = CI Text
+type SchoolShorthand = CI Text
+type CourseName      = CI Text
+type CourseShorthand = CI Text
+type SheetName       = CI Text
+type MaterialName    = CI Text
+type UserEmail       = CI Email
+type TutorialName    = CI Text
+
+type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
+type InstanceId      = UUID
+type ClusterId       = UUID
+type TokenId         = UUID
+type TermCandidateIncidence = UUID

src/Model/Types/Course.hs

@@ -0,0 +1,20 @@
+module Model.Types.Course
+  ( module Model.Types.Course
+  ) where
+
+import Import.NoModel
+
+
+data LecturerType = CourseLecturer | CourseAssistant
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe LecturerType
+instance Finite LecturerType
+
+nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
+deriveJSON  defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''LecturerType
+derivePersistFieldJSON ''LecturerType
+
+instance Hashable LecturerType

src/Model/Types/DateTime.hs

@@ -1,34 +1,22 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
+module Model.Types.DateTime
-           , UndecidableInstances
+  ( module Model.Types.DateTime
-  #-}
+  ) where
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
-module Model.Types.DateTime where
+import Import.NoModel
-
-
-import ClassyPrelude
-import GHC.Generics (Generic)
-import Utils
 import Control.Lens
-import Data.NonNull.Instances ()
-import Data.Typeable (Typeable)
-import Data.Universe.Instances.Reverse ()
-import Data.Binary (Binary)
 
-import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
-import Data.CaseInsensitive.Instances ()
 import Text.Read (readMaybe)
 
-import Database.Persist.Class
 import Database.Persist.Sql
 
 import Web.HttpApiData
 
-import Yesod.Core.Dispatch (PathPiece(..))
+import Data.Aeson.Types as Aeson
-import qualified Data.Aeson as Aeson
+
-import Data.Aeson (FromJSON(..), ToJSON(..), withText)
+import Time.Types (WeekDay(..))
+import Data.Time.LocalTime (LocalTime, TimeOfDay)
 
 
 ----
@@ -156,3 +144,44 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
     timeYear = fst3 $ toGregorian time
     termYear = year term
 
+
+data OccurenceSchedule = ScheduleWeekly
+                         { scheduleDayOfWeek :: WeekDay
+                         , scheduleStart     :: TimeOfDay
+                         , scheduleEnd       :: TimeOfDay
+                         }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 1
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "repeat" "schedule"
+  } ''OccurenceSchedule
+
+data OccurenceException = ExceptOccur
+                          { exceptDay   :: Day
+                          , exceptStart :: TimeOfDay
+                          , exceptEnd   :: TimeOfDay
+                          }
+                        | ExceptNoOccur
+                          { exceptTime  :: LocalTime
+                          }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = TaggedObject "exception" "for"
+  } ''OccurenceException
+
+data Occurences = Occurences
+  { occurencesScheduled  :: Set OccurenceSchedule
+  , occurencesExceptions :: Set OccurenceException
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''Occurences
+derivePersistFieldJSON ''Occurences
+

src/Model/Types/Exam.hs

@@ -0,0 +1,12 @@
+module Model.Types.Exam
+  ( module Model.Types.Exam
+  ) where
+
+import Import.NoModel
+
+import Database.Persist.TH (derivePersistField)
+
+
+data ExamStatus = Attended | NoShow | Voided
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+derivePersistField "ExamStatus"

src/Model/Types/Health.hs

@@ -0,0 +1,83 @@
+module Model.Types.Health
+  ( module Model.Types.Health
+  ) where
+
+import Import.NoModel
+
+
+data HealthCheck
+  = HealthCheckMatchingClusterConfig
+  | HealthCheckHTTPReachable
+  | HealthCheckLDAPAdmins
+  | HealthCheckSMTPConnect
+  | HealthCheckWidgetMemcached
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe HealthCheck
+instance Finite HealthCheck
+instance Hashable HealthCheck
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  } ''HealthCheck
+nullaryPathPiece ''HealthCheck $ camelToPathPiece' 2
+pathPieceJSONKey ''HealthCheck
+  
+data HealthReport
+  = HealthMatchingClusterConfig { healthMatchingClusterConfig :: Bool }
+    -- ^ Is the database-stored configuration we're running under still up to date?
+    --
+    -- Also tests database connection as a side effect
+  | HealthHTTPReachable { healthHTTPReachable :: Maybe Bool }
+    -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
+  | HealthLDAPAdmins { healthLDAPAdmins :: Maybe Rational }
+    -- ^ Proportion of school admins that could be found in LDAP
+  | HealthSMTPConnect { healthSMTPConnect :: Maybe Bool }
+    -- ^ Can we connect to the SMTP server and say @NOOP@?
+  | HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool }
+    -- ^ Can we store values in memcached and retrieve them via HTTP?
+  deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
+
+instance NFData HealthReport
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , fieldLabelModifier = camelToPathPiece' 1
+  , omitNothingFields  = True
+  , sumEncoding = TaggedObject "test" "result"
+  , tagSingleConstructors = True
+  } ''HealthReport
+
+classifyHealthReport :: HealthReport -> HealthCheck
+classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig
+classifyHealthReport HealthLDAPAdmins{}            = HealthCheckLDAPAdmins
+classifyHealthReport HealthHTTPReachable{}         = HealthCheckHTTPReachable
+classifyHealthReport HealthSMTPConnect{}           = HealthCheckSMTPConnect
+classifyHealthReport HealthWidgetMemcached{}       = HealthCheckWidgetMemcached
+
+-- | `HealthReport` classified (`classifyHealthReport`) by badness
+--
+-- > a < b = a `worseThan` b
+--
+-- Currently all consumers of this type check for @(== HealthSuccess)@; this
+-- needs to be adjusted on a case-by-case basis if new constructors are added
+data HealthStatus = HealthFailure | HealthSuccess
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe HealthStatus
+instance Finite HealthStatus
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''HealthStatus
+nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
+
+healthReportStatus :: HealthReport -> HealthStatus
+-- ^ Classify `HealthReport` by badness
+healthReportStatus = \case
+  HealthMatchingClusterConfig       False  -> HealthFailure
+  HealthHTTPReachable         (Just False) -> HealthFailure
+  HealthLDAPAdmins            (Just prop )
+    | prop <= 0                            -> HealthFailure
+  HealthSMTPConnect           (Just False) -> HealthFailure 
+  HealthWidgetMemcached       (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully?
+  _other                                   -> maxBound -- Minimum badness

src/Model/Types/Mail.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Model.Types.Mail
+  ( module Model.Types.Mail
+  ) where
+
+import Import.NoModel
+
+import qualified Data.Aeson.Types as Aeson
+
+import qualified Data.HashMap.Strict as HashMap
+
+
+-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
+--
+-- Could maybe be replaced with `Structure Notification` in the long term
+data NotificationTrigger
+  = NTSubmissionRatedGraded
+  | NTSubmissionRated
+  | NTSheetActive
+  | NTSheetSoonInactive
+  | NTSheetInactive
+  | NTCorrectionsAssigned
+  | NTCorrectionsNotDistributed
+  | NTUserRightsUpdate
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe NotificationTrigger
+instance Finite NotificationTrigger
+
+instance Hashable NotificationTrigger
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''NotificationTrigger
+
+instance ToJSONKey NotificationTrigger where
+  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
+
+instance FromJSONKey NotificationTrigger where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
+
+
+newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
+  deriving (Generic, Typeable)
+  deriving newtype (Eq, Ord, Read, Show)
+
+instance Default NotificationSettings where
+  def = NotificationSettings $ \case
+    NTSubmissionRatedGraded -> True
+    NTSubmissionRated -> False
+    NTSheetActive -> True
+    NTSheetSoonInactive -> False
+    NTSheetInactive -> True
+    NTCorrectionsAssigned -> True
+    NTCorrectionsNotDistributed -> True
+    NTUserRightsUpdate -> True
+
+instance ToJSON NotificationSettings where
+  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
+
+instance FromJSON NotificationSettings where
+  parseJSON = Aeson.withObject "NotificationSettings" $ \o -> do
+    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
+    return . NotificationSettings $ \n -> case HashMap.lookup n o' of
+      Nothing -> notificationAllowed def n
+      Just b  -> b
+
+derivePersistFieldJSON ''NotificationSettings

src/Model/Types/Misc.hs

@@ -1,50 +1,20 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
+module Model.Types.Misc
-           , UndecidableInstances
+  ( module Model.Types.Misc
-  #-}
+  ) where
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
-module Model.Types.Misc where
+import Import.NoModel
-
-
-import ClassyPrelude
-import Utils
 import Control.Lens
 
-import Data.NonNull.Instances ()
-import Data.Set (Set)
 import Data.Maybe (fromJust)
-import Data.Universe
-import Data.Universe.Helpers
 
 import qualified Data.Text as Text
 import qualified Data.Text.Lens as Text
-import Data.CaseInsensitive.Instances ()
 
-import Database.Persist.TH hiding (derivePersistFieldJSON)
-import Model.Types.JSON
-
-import Data.Aeson (Value())
-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
-
-import GHC.Generics (Generic)
-import Data.Typeable (Typeable)
-
-import Data.Universe.Instances.Reverse ()
-
-import Data.Time.LocalTime (LocalTime, TimeOfDay)
-import Time.Types (WeekDay(..))
-
-
------
--- Miscellaneous Model.Types
-
-derivePersistFieldJSON ''Value
 
 data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
 derivePersistField "StudyFieldType"
 
--- instance DisplayAble StudyFieldType
 
 data Theme
   = ThemeDefault
@@ -59,89 +29,11 @@ deriveJSON defaultOptions
   { constructorTagModifier = fromJust . stripPrefix "Theme"
   } ''Theme
 
-instance Universe Theme where universe = universeDef
+instance Universe Theme
 instance Finite Theme
 
-nullaryPathPiece ''Theme (camelToPathPiece' 1)
+nullaryPathPiece ''Theme $ camelToPathPiece' 1
 
 $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
 
 derivePersistField "Theme"
-
-
-data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = fromJust . stripPrefix "Corrector"
-  } ''CorrectorState
-
-instance Universe CorrectorState
-instance Finite CorrectorState
-
-instance Hashable CorrectorState
-
-nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
-
-derivePersistField "CorrectorState"
-
-
-data LecturerType = CourseLecturer | CourseAssistant
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-
-instance Universe LecturerType
-instance Finite LecturerType
-
-nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
-deriveJSON  defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  } ''LecturerType
-derivePersistFieldJSON ''LecturerType
-
-instance Hashable LecturerType
-
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece
-  } ''WeekDay
-
-data OccurenceSchedule = ScheduleWeekly
-                         { scheduleDayOfWeek :: WeekDay
-                         , scheduleStart     :: TimeOfDay
-                         , scheduleEnd       :: TimeOfDay
-                         }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  , constructorTagModifier = camelToPathPiece' 1
-  , tagSingleConstructors = True
-  , sumEncoding = TaggedObject "repeat" "schedule"
-  } ''OccurenceSchedule
-
-data OccurenceException = ExceptOccur
-                          { exceptDay   :: Day
-                          , exceptStart :: TimeOfDay
-                          , exceptEnd   :: TimeOfDay
-                          }
-                        | ExceptNoOccur
-                          { exceptTime  :: LocalTime
-                          }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  , constructorTagModifier = camelToPathPiece' 1
-  , sumEncoding = TaggedObject "exception" "for"
-  } ''OccurenceException
-
-data Occurences = Occurences
-  { occurencesScheduled  :: Set OccurenceSchedule
-  , occurencesExceptions :: Set OccurenceException
-  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  } ''Occurences
-derivePersistFieldJSON ''Occurences
-

src/Model/Types/Security.hs

@@ -1,80 +1,22 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-           , UndecidableInstances
-  #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
-module Model.Types.Security where
+module Model.Types.Security
+  ( module Model.Types.Security
+  ) where
 
-
+import Import.NoModel
-import ClassyPrelude
-import Utils
-import Control.Lens hiding (universe)
 
 import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Universe
-import Data.UUID.Types (UUID)
-import qualified Data.UUID.Types as UUID
 
-import Data.NonNull.Instances ()
-
-import Data.Default
-
-import Model.Types.JSON
-import Database.Persist.Class
-import Database.Persist.Sql
-
-import Data.Text (Text)
 import qualified Data.Text as Text
 
 import qualified Data.HashMap.Strict as HashMap
 
-import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
-import Data.CaseInsensitive.Instances ()
-
-import Yesod.Core.Dispatch (PathPiece(..))
-import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
-import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withObject)
-import Data.Aeson.Types (toJSONKeyText)
-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON)
 
-import GHC.Generics (Generic)
-import Data.Typeable (Typeable)
-
-import Data.Universe.Instances.Reverse ()
-
-import Mail (MailLanguages(..))
-
-import Data.Word.Word24 (Word24)
-import Data.Bits
-import Data.Ix
-import Data.List (genericIndex, elemIndex)
-import System.Random (Random(..))
-import Data.Data (Data)
-
-import Model.Types.Wordlist
-import Data.Text.Metrics (damerauLevenshtein)
-
-import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
 
-----
--- Security, Authentification, Notification Stuff
-
-instance PersistField UUID where
-  toPersistValue = PersistDbSpecific . UUID.toASCIIBytes
-  fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t
-  fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
-  fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
-  fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x
-
-instance PersistFieldSql UUID where
-  sqlType _ = SqlOther "uuid"
-
-
 data AuthenticationMode = AuthLDAP
                         | AuthPWHash { authPWHash :: Text }
   deriving (Eq, Ord, Read, Show, Generic)
@@ -88,167 +30,6 @@ deriveJSON defaultOptions
 derivePersistFieldJSON ''AuthenticationMode
 
 
-
--- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
---
--- Could maybe be replaced with `Structure Notification` in the long term
-data NotificationTrigger = NTSubmissionRatedGraded
-                         | NTSubmissionRated
-                         | NTSheetActive
-                         | NTSheetSoonInactive
-                         | NTSheetInactive
-                         | NTCorrectionsAssigned
-                         | NTCorrectionsNotDistributed
-                         | NTUserRightsUpdate
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-
-instance Universe NotificationTrigger
-instance Finite NotificationTrigger
-
-instance Hashable NotificationTrigger
-
-deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  } ''NotificationTrigger
-
-instance ToJSONKey NotificationTrigger where
-  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
-
-instance FromJSONKey NotificationTrigger where
-  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
-
-
-newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
-  deriving (Generic, Typeable)
-  deriving newtype (Eq, Ord, Read, Show)
-
-instance Default NotificationSettings where
-  def = NotificationSettings $ \case
-    NTSubmissionRatedGraded -> True
-    NTSubmissionRated -> False
-    NTSheetActive -> True
-    NTSheetSoonInactive -> False
-    NTSheetInactive -> True
-    NTCorrectionsAssigned -> True
-    NTCorrectionsNotDistributed -> True
-    NTUserRightsUpdate -> True
-
-instance ToJSON NotificationSettings where
-  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
-
-instance FromJSON NotificationSettings where
-  parseJSON = withObject "NotificationSettings" $ \o -> do
-    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
-    return . NotificationSettings $ \n -> case HashMap.lookup n o' of
-      Nothing -> notificationAllowed def n
-      Just b  -> b
-
-derivePersistFieldJSON ''NotificationSettings
-
-
-instance ToBackendKey SqlBackend record => Hashable (Key record) where
-  hashWithSalt s key = s `hashWithSalt` fromSqlKey key
-
-derivePersistFieldJSON ''MailLanguages
-
-
-type PseudonymWord   = CI Text
-
-newtype Pseudonym = Pseudonym Word24
-  deriving (Eq, Ord, Read, Show, Generic, Data)
-  deriving newtype (Bounded, Enum, Integral, Num, Real, Ix)
-
-
-instance PersistField Pseudonym where
-  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
-  fromPersistValue v = do
-    w <- fromPersistValue v :: Either Text Word32
-    if
-      | 0 <= w
-      , w <= fromIntegral (maxBound :: Pseudonym)
-        -> return $ fromIntegral w
-      | otherwise
-        -> Left "Pseudonym out of range"
-
-instance PersistFieldSql Pseudonym where
-  sqlType _ = SqlInt32
-
-instance Random Pseudonym where
-  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
-  random = randomR (minBound, maxBound)
-
-instance FromJSON Pseudonym where
-  parseJSON v@(Aeson.Number _) = do
-    w <- parseJSON v :: Aeson.Parser Word32
-    if
-      | 0 <= w
-      , w <= fromIntegral (maxBound :: Pseudonym)
-        -> return $ fromIntegral w
-      | otherwise
-        -> fail "Pseudonym out auf range"
-  parseJSON (Aeson.String t)
-    = case t ^? _PseudonymText of
-        Just p -> return p
-        Nothing -> fail "Could not parse pseudonym"
-  parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
-    ws' <- toList . map CI.mk <$> mapM parseJSON ws
-    case ws' ^? _PseudonymWords of
-      Just p -> return p
-      Nothing -> fail "Could not parse pseudonym words"
-
-instance ToJSON Pseudonym where
-  toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord])
-
-pseudonymWordlist :: [PseudonymWord]
-pseudonymCharacters :: Set (CI Char)
-(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt")
-
-_PseudonymWords :: Prism' [PseudonymWord] Pseudonym
-_PseudonymWords = prism' pToWords pFromWords
-  where
-    pFromWords :: [PseudonymWord] -> Maybe Pseudonym
-    pFromWords [w1, w2]
-      | Just i1 <- elemIndex w1 pseudonymWordlist
-      , Just i2 <- elemIndex w2 pseudonymWordlist
-      , i1 <= maxWord, i2 <= maxWord
-      = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2
-    pFromWords _ = Nothing
-
-    pToWords :: Pseudonym -> [PseudonymWord]
-    pToWords (Pseudonym p)
-      = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord
-        , genericIndex pseudonymWordlist $ p .&. maxWord
-        ]
-
-    maxWord :: Num a => a
-    maxWord = 0b111111111111
-
-_PseudonymText :: Prism' Text Pseudonym
-_PseudonymText = prism' tToWords tFromWords . _PseudonymWords
-  where
-    tFromWords :: Text -> Maybe [PseudonymWord]
-    tFromWords input
-      | [result] <- input ^.. pseudonymFragments
-      = Just result
-      | otherwise
-      = Nothing
-
-    tToWords :: [PseudonymWord] -> Text
-    tToWords = Text.unwords . map CI.original
-
-pseudonymWords :: Fold Text PseudonymWord
-pseudonymWords = folding
-  $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
-  where
-    distance = damerauLevenshtein `on` CI.foldedCase
-    -- | Arbitrary cutoff point, for reference: ispell cuts off at 1
-    distanceCutoff = 2
-
-pseudonymFragments :: Fold Text [PseudonymWord]
-pseudonymFragments = folding
-  $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)
-
-
 data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
   = AuthAdmin
   | AuthLecturer
@@ -309,7 +90,7 @@ instance ToJSON AuthTagActive where
   toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF
 
 instance FromJSON AuthTagActive where
-  parseJSON = withObject "AuthTagActive" $ \o -> do
+  parseJSON = Aeson.withObject "AuthTagActive" $ \o -> do
     o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool)
     return . AuthTagActive $ \n -> case HashMap.lookup n o' of
       Nothing -> authTagIsActive def n
@@ -355,81 +136,3 @@ instance (Ord a, Binary a) => Binary (PredDNF a) where
 type AuthLiteral = PredLiteral AuthTag
 
 type AuthDNF = PredDNF AuthTag
-
-
-data HealthCheck
-  = HealthCheckMatchingClusterConfig
-  | HealthCheckHTTPReachable
-  | HealthCheckLDAPAdmins
-  | HealthCheckSMTPConnect
-  | HealthCheckWidgetMemcached
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-instance Universe HealthCheck
-instance Finite HealthCheck
-instance Hashable HealthCheck
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 2
-  } ''HealthCheck
-nullaryPathPiece ''HealthCheck $ camelToPathPiece' 2
-pathPieceJSONKey ''HealthCheck
-  
-data HealthReport
-  = HealthMatchingClusterConfig { healthMatchingClusterConfig :: Bool }
-    -- ^ Is the database-stored configuration we're running under still up to date?
-    --
-    -- Also tests database connection as a side effect
-  | HealthHTTPReachable { healthHTTPReachable :: Maybe Bool }
-    -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
-  | HealthLDAPAdmins { healthLDAPAdmins :: Maybe Rational }
-    -- ^ Proportion of school admins that could be found in LDAP
-  | HealthSMTPConnect { healthSMTPConnect :: Maybe Bool }
-    -- ^ Can we connect to the SMTP server and say @NOOP@?
-  | HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool }
-    -- ^ Can we store values in memcached and retrieve them via HTTP?
-  deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
-
-instance NFData HealthReport
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  , fieldLabelModifier = camelToPathPiece' 1
-  , omitNothingFields  = True
-  , sumEncoding = TaggedObject "test" "result"
-  , tagSingleConstructors = True
-  } ''HealthReport
-
-classifyHealthReport :: HealthReport -> HealthCheck
-classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig
-classifyHealthReport HealthLDAPAdmins{}            = HealthCheckLDAPAdmins
-classifyHealthReport HealthHTTPReachable{}         = HealthCheckHTTPReachable
-classifyHealthReport HealthSMTPConnect{}           = HealthCheckSMTPConnect
-classifyHealthReport HealthWidgetMemcached{}       = HealthCheckWidgetMemcached
-
--- | `HealthReport` classified (`classifyHealthReport`) by badness
---
--- > a < b = a `worseThan` b
---
--- Currently all consumers of this type check for @(== HealthSuccess)@; this
--- needs to be adjusted on a case-by-case basis if new constructors are added
-data HealthStatus = HealthFailure | HealthSuccess
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-
-instance Universe HealthStatus
-instance Finite HealthStatus
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  } ''HealthStatus
-nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
-
-healthReportStatus :: HealthReport -> HealthStatus
--- ^ Classify `HealthReport` by badness
-healthReportStatus = \case
-  HealthMatchingClusterConfig       False  -> HealthFailure
-  HealthHTTPReachable         (Just False) -> HealthFailure
-  HealthLDAPAdmins            (Just prop )
-    | prop <= 0                            -> HealthFailure
-  HealthSMTPConnect           (Just False) -> HealthFailure 
-  HealthWidgetMemcached       (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully?
-  _other                                   -> maxBound -- Minimum badness

src/Model/Types/Sheet.hs

@@ -1,62 +1,26 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
+module Model.Types.Sheet
-           , UndecidableInstances
+  ( module Model.Types.Sheet
-  #-}
+  ) where
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
-module Model.Types.Sheet where
+import Import.NoModel
-
+import Model.Types.Common
-import ClassyPrelude
+import Utils.Lens.TH
-import Utils
-import Numeric.Natural
 
 import Control.Lens
-import Utils.Lens.TH
-import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
-import Data.Typeable (Typeable)
-import Data.Universe
-import Data.Universe.Helpers
-import Data.Universe.Instances.Reverse ()
 
-import Data.NonNull.Instances ()
 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.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
 
-import Data.CaseInsensitive.Instances ()
 import Text.Blaze (Markup)
 
-import Database.Persist.TH hiding (derivePersistFieldJSON)
-import Model.Types.JSON
 import Yesod.Core.Dispatch (PathPiece(..))
 
-import Network.Mime
+import Data.Maybe (fromJust)
 
 
-
-----
--- Sheet and Submission realted Model.Types
-
-type Count  = Sum Integer
-type Points = Centi
-
-toPoints :: Integral a => a -> Points -- deprecated
-toPoints = fromIntegral
-
-pToI :: Points -> Integer -- deprecated
-pToI = fromPoints
-
-fromPoints :: Integral a => Points -> a -- deprecated
-fromPoints = round
-
-instance DisplayAble Points
-
-instance DisplayAble a => DisplayAble (Sum a) where
-   display (Sum x) = display x
-
 data SheetGrading
   = Points     { maxPoints :: Points }
   | PassPoints { maxPoints, passingPoints :: Points }
@@ -179,7 +143,7 @@ data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
 derivePersistField "SheetFileType"
 
-instance Universe SheetFileType where universe = universeDef
+instance Universe SheetFileType
 instance Finite SheetFileType
 
 instance PathPiece SheetFileType where
@@ -208,22 +172,6 @@ sheetFile2markup SheetMarking  = iconMarking
 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, Generic)
-
-instance Universe SubmissionFileType
-instance Finite SubmissionFileType
-
-nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
-
-submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
-submissionFileTypeIsUpdate SubmissionOriginal  = False
-submissionFileTypeIsUpdate SubmissionCorrected = True
-
-isUpdateSubmissionFileType :: Bool -> SubmissionFileType
-isUpdateSubmissionFileType False = SubmissionOriginal
-isUpdateSubmissionFileType True  = SubmissionCorrected
-
 
 data UploadSpecificFile = UploadSpecificFile
   { specificFileLabel :: Text
@@ -306,10 +254,6 @@ classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
 classifySubmissionMode (SubmissionMode True  (Just _)) = SubmissionModeBoth
 
 
-data ExamStatus = Attended | NoShow | Voided
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
-derivePersistField "ExamStatus"
-
 -- | 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
@@ -340,3 +284,19 @@ instance Monoid Load where
   isByTutorial (ByTutorial {}) = True
   isByTutorial _               = False
 -}
+
+data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = fromJust . stripPrefix "Corrector"
+  } ''CorrectorState
+
+instance Universe CorrectorState
+instance Finite CorrectorState
+
+instance Hashable CorrectorState
+
+nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
+
+derivePersistField "CorrectorState"

src/Model/Types/Submission.hs

@@ -0,0 +1,146 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Model.Types.Submission
+  ( module Model.Types.Submission
+  ) where
+
+import Import.NoModel
+
+import Data.Aeson.Types (ToJSON(..), FromJSON(..))
+import qualified Data.Aeson.Types as Aeson
+
+import Database.Persist.Sql
+
+import Data.Word.Word24
+
+import qualified Data.CaseInsensitive as CI
+
+import Control.Lens
+
+import qualified Data.Text as Text
+import qualified Data.Set as Set
+
+
+import Data.List (elemIndex, genericIndex)
+import Data.Bits
+import Data.Text.Metrics (damerauLevenshtein)
+  
+-------------------------
+-- Submission Download --
+-------------------------
+
+data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+
+instance Universe SubmissionFileType
+instance Finite SubmissionFileType
+
+nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
+
+submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
+submissionFileTypeIsUpdate SubmissionOriginal  = False
+submissionFileTypeIsUpdate SubmissionCorrected = True
+
+isUpdateSubmissionFileType :: Bool -> SubmissionFileType
+isUpdateSubmissionFileType False = SubmissionOriginal
+isUpdateSubmissionFileType True  = SubmissionCorrected
+
+---------------------------
+-- Submission Pseudonyms --
+---------------------------
+  
+type PseudonymWord = CI Text
+
+newtype Pseudonym = Pseudonym Word24
+  deriving (Eq, Ord, Read, Show, Generic, Data)
+  deriving newtype (Bounded, Enum, Integral, Num, Real, Ix)
+
+
+instance PersistField Pseudonym where
+  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
+  fromPersistValue v = do
+    w <- fromPersistValue v :: Either Text Word32
+    if
+      | 0 <= w
+      , w <= fromIntegral (maxBound :: Pseudonym)
+        -> return $ fromIntegral w
+      | otherwise
+        -> Left "Pseudonym out of range"
+
+instance PersistFieldSql Pseudonym where
+  sqlType _ = SqlInt32
+
+instance Random Pseudonym where
+  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
+  random = randomR (minBound, maxBound)
+
+instance FromJSON Pseudonym where
+  parseJSON v@(Aeson.Number _) = do
+    w <- parseJSON v :: Aeson.Parser Word32
+    if
+      | 0 <= w
+      , w <= fromIntegral (maxBound :: Pseudonym)
+        -> return $ fromIntegral w
+      | otherwise
+        -> fail "Pseudonym out auf range"
+  parseJSON (Aeson.String t)
+    = case t ^? _PseudonymText of
+        Just p -> return p
+        Nothing -> fail "Could not parse pseudonym"
+  parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
+    ws' <- toList . map CI.mk <$> mapM parseJSON ws
+    case ws' ^? _PseudonymWords of
+      Just p -> return p
+      Nothing -> fail "Could not parse pseudonym words"
+
+instance ToJSON Pseudonym where
+  toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord])
+
+pseudonymWordlist :: [PseudonymWord]
+pseudonymCharacters :: Set (CI Char)
+(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt")
+
+_PseudonymWords :: Prism' [PseudonymWord] Pseudonym
+_PseudonymWords = prism' pToWords pFromWords
+  where
+    pFromWords :: [PseudonymWord] -> Maybe Pseudonym
+    pFromWords [w1, w2]
+      | Just i1 <- elemIndex w1 pseudonymWordlist
+      , Just i2 <- elemIndex w2 pseudonymWordlist
+      , i1 <= maxWord, i2 <= maxWord
+      = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2
+    pFromWords _ = Nothing
+
+    pToWords :: Pseudonym -> [PseudonymWord]
+    pToWords (Pseudonym p)
+      = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord
+        , genericIndex pseudonymWordlist $ p .&. maxWord
+        ]
+
+    maxWord :: Num a => a
+    maxWord = 0b111111111111
+
+_PseudonymText :: Prism' Text Pseudonym
+_PseudonymText = prism' tToWords tFromWords . _PseudonymWords
+  where
+    tFromWords :: Text -> Maybe [PseudonymWord]
+    tFromWords input
+      | [result] <- input ^.. pseudonymFragments
+      = Just result
+      | otherwise
+      = Nothing
+
+    tToWords :: [PseudonymWord] -> Text
+    tToWords = Text.unwords . map CI.original
+
+pseudonymWords :: Fold Text PseudonymWord
+pseudonymWords = folding
+  $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
+  where
+    distance = damerauLevenshtein `on` CI.foldedCase
+    -- | Arbitrary cutoff point, for reference: ispell cuts off at 1
+    distanceCutoff = 2
+
+pseudonymFragments :: Fold Text [PseudonymWord]
+pseudonymFragments = folding
+  $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)

src/Model/Types/TH/JSON.hs

@@ -1,4 +1,4 @@
-module Model.Types.JSON
+module Model.Types.TH.JSON
   ( derivePersistFieldJSON
   , predNFAesonOptions
   ) where

src/Model/Types/TH/Wordlist.hs

@@ -1,4 +1,6 @@
-module Model.Types.Wordlist (wordlist) where
+module Model.Types.TH.Wordlist
+  ( wordlist
+  ) where
 
 import ClassyPrelude hiding (lift)
 

src/Settings.hs

@@ -10,14 +10,13 @@ module Settings
   , module Settings.Cluster
   ) where
 
-import           ClassyPrelude.Yesod
+import           Import.NoModel
 import Data.UUID (UUID)
 import qualified Control.Exception           as Exception
-import           Data.Aeson                  (Result (..), fromJSON, withObject
+import           Data.Aeson                  (fromJSON, withObject
                                              ,(.!=), (.:?), withScientific
                                              )
 import qualified Data.Aeson.Types as Aeson
-import           Data.Aeson.TH
 import           Data.FileEmbed              (embedFile)
 import           Data.Yaml                   (decodeEither')
 import           Database.Persist.Postgresql (PostgresConf)
@@ -45,7 +44,6 @@ import qualified Data.Text.Encoding as Text
 
 import qualified Ldap.Client as Ldap
 
-import Utils hiding (MessageStatus(..))
 import Control.Lens
 
 import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
@@ -70,7 +68,6 @@ import Jose.Jwt (JwtEncoding(..))
 
 import System.FilePath.Glob
 import Handler.Utils.Submission.TH
-import Network.Mime
 import Network.Mime.TH
 
 import qualified Data.Map as Map
@@ -483,5 +480,5 @@ configSettingsYmlValue = either Exception.throw id
 compileTimeAppSettings :: AppSettings
 compileTimeAppSettings =
     case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
-        Error e -> error e
+        Aeson.Error e -> error e
-        Success settings -> settings
+        Aeson.Success settings -> settings

src/System/FilePath/Instances.hs

@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module System.FilePath.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import qualified Data.Text as Text
+
+import Web.PathPieces
+
+
+instance {-# OVERLAPS #-} PathMultiPiece FilePath where
+  fromPathMultiPiece = Just . unpack . intercalate "/"
+  toPathMultiPiece = Text.splitOn "/" . pack

src/Time/Types/Instances.hs

@@ -12,8 +12,14 @@ import Data.Universe
 
 import Utils.PathPiece
 
+import Data.Aeson.TH
+
 
 instance Universe WeekDay
 instance Finite WeekDay
 
 nullaryPathPiece ''WeekDay camelToPathPiece
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  } ''WeekDay

src/Utils.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
-
 module Utils
   ( module Utils
   ) where
@@ -68,7 +66,7 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox
 import qualified Crypto.Saltine.Class as Saltine
 import qualified Crypto.Data.PKCS7 as PKCS7
 
-import Data.Fixed (Centi)
+import Data.Fixed
 import Data.Ratio ((%))
 
 import qualified Data.Binary as Binary
@@ -277,6 +275,12 @@ instance DisplayAble a => DisplayAble (E.Value a) where
 instance DisplayAble a => DisplayAble (CI a) where
   display = display . CI.original
 
+instance HasResolution a => DisplayAble (Fixed a) where
+  display = pack . showFixed True
+
+instance DisplayAble a => DisplayAble (Sum a) where
+  display = display . getSum
+
 {- 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!

src/Utils/DateTime.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Utils.DateTime
   ( timeLocaleMap
@@ -14,10 +13,9 @@ module Utils.DateTime
 import ClassyPrelude.Yesod hiding (lift)
 import System.Locale.Read
 
-import Data.Time (TimeZone(..), TimeLocale(..))
+import Data.Time (TimeLocale(..))
 import Data.Time.Zones (TZ)
 import Data.Time.Zones.TH (includeSystemTZ)
-import Data.Time.Clock.POSIX
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
@@ -35,11 +33,8 @@ import Data.Aeson.TH
 
 import Utils.PathPiece
 
-deriving instance Lift TimeZone
+import Data.Time.Format.Instances ()
-deriving instance Lift TimeLocale
+  
-
-instance Hashable UTCTime where
-  hashWithSalt s = hashWithSalt s . toRational . utcTimeToPOSIXSeconds
 
 -- $(timeLocaleMap _) :: [Lang] -> TimeLocale
 timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
@@ -91,7 +86,7 @@ instance Finite SelDateTimeFormat
 instance Hashable SelDateTimeFormat
 
 deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+  { constructorTagModifier = camelToPathPiece' 2
   } ''SelDateTimeFormat
 
 instance ToJSONKey SelDateTimeFormat where

test/MailSpec.hs

@@ -27,7 +27,7 @@ spec = do
     lawsCheckHspec (Proxy @MailSmtpData)
       [ eqLaws, ordLaws, showReadLaws, monoidLaws ]
     lawsCheckHspec (Proxy @MailLanguages)
-      [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
+      [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @MailContext)
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
     lawsCheckHspec (Proxy @VerpMode)

test/Model/TypesSpec.hs

@@ -267,8 +267,6 @@ spec = do
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
     lawsCheckHspec (Proxy @NotificationSettings)
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    lawsCheckHspec (Proxy @MailLanguages)
-      [ persistFieldLaws ]
     lawsCheckHspec (Proxy @Pseudonym)
       [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @AuthTag)

test/TestImport.hs

@@ -32,6 +32,7 @@ import Data.Proxy as X
 import Data.UUID as X (UUID)
 import System.IO as X (hPrint, hPutStrLn, stderr)
 import Jobs (handleJobs, stopJobCtl)
+import Numeric.Natural as X
 
 import Control.Lens as X hiding ((<.), elements)
 

test/Utils/DateTimeSpec.hs

@@ -2,6 +2,9 @@ module Utils.DateTimeSpec where
 
 import TestImport
 
+import Utils.DateTime
+
+
 instance Arbitrary DateTimeFormat where
   arbitrary = DateTimeFormat <$> arbitrary
   shrink = genericShrink