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

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source
This commit is contained in:
SJost 2019-01-23 18:37:35 +01:00
commit e19540556f
43 changed files with 557 additions and 224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
ChangeLog.md
View File

@ -3,6 +3,8 @@
Links für Bequemlichkeiten hinzugefügt (z.B. aktuelles Übungsblatt)
Liste zugewiesener Abgaben lassen sich nun filtern
Bugfix: Wenn zwischen Anzeige und Empfang eines Tabellen-Formulars Zeilen verschwinden wird nun eine sinnvolle Fehlermeldung angezeigt
* Version 30.11.2018

3
config/settings.yml
View File

@ -66,7 +66,8 @@ ldap:
pass: "_env:LDAPPASS:"
baseDN: "_env:LDAPBASE:"
scope: "_env:LDAPSCOPE:WholeSubtree"
timeout: "_env:LDAPSEARCHTIME:5"
timeout: "_env:LDAPTIMEOUT:5"
search-timeout: "_env:LDAPSEARCHTIME:5"
pool:
stripes: "_env:LDAPSTRIPES:1"
timeout: "_env:LDAPTIMEOUT:20"

3
haddock.sh Executable file
View File

@ -0,0 +1,3 @@
#!/usr/bin/env bash
exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal

4
messages/uniworx/de.msg
View File

@ -604,4 +604,6 @@ AuthTagWrite: Zugriff ist i.A. schreibend
DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab.
DeleteConfirmation: Bestätigung
DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde

1
models/courses
View File

@ -19,6 +19,7 @@ Course
materialFree Bool
TermSchoolCourseShort term school shorthand
TermSchoolCourseName term school name
deriving Generic
CourseEdit
user UserId
time UTCTime

2
models/schools
View File

@ -4,4 +4,4 @@ School json
UniqueSchool name
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
deriving Eq
deriving Eq Show Generic

1
models/sheets
View File

@ -14,6 +14,7 @@ Sheet
submissionMode SheetSubmissionMode default='UserSubmissions'
autoDistribute Bool default=false
CourseSheet course name
deriving Generic
SheetEdit
user UserId
time UTCTime

2
models/submissions
View File

@ -5,7 +5,7 @@ Submission
ratingBy UserId Maybe -- assigned corrector
ratingAssigned UTCTime Maybe -- time assigned corrector
ratingTime UTCTime Maybe -- "Just" here indicates done!
deriving Show
deriving Show Generic
SubmissionEdit
user UserId
time UTCTime

2
models/terms
View File

@ -7,4 +7,4 @@ Term json
lectureEnd Day
active Bool
Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
deriving Show -- type TermId = Key Term
deriving Show Eq Generic -- type TermId = Key Term

2
models/users
View File

@ -15,7 +15,7 @@ User json
notificationSettings NotificationSettings
UniqueAuthentication ident
UniqueEmail email
deriving Show Eq
deriving Show Eq Generic
UserAdmin
user UserId
school SchoolId

4
package.yaml
View File

@ -113,6 +113,7 @@ dependencies:
- pkcs7
- memcached-binary
- directory-tree
- lifted-base
other-extensions:
- GeneralizedNewtypeDeriving
@ -231,6 +232,9 @@ tests:
- http-types
ghc-options:
- -fno-warn-orphans
- -threaded
- -rtsopts
- -with-rtsopts=-N
hlint:
main: Hlint.hs
other-modules: []

4
src/Application.hs
View File

@ -157,7 +157,7 @@ makeFoundation appSettings@AppSettings{..} = do
flip runLoggingT logFunc $ do
$logDebugS "InstanceID" $ UUID.toText appInstanceID
-- $logDebugS "Configuration" $ tshow appSettings
-- logDebugS "Configuration" $ tshow appSettings
smtpPool <- traverse createSmtpPool appSmtpConf
@ -168,7 +168,7 @@ makeFoundation appSettings@AppSettings{..} = do
(pgConnStr appDatabaseConf)
(pgPoolSize appDatabaseConf)
ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) (poolLimit ldapPool)
ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
-- Perform database migration using our application's logging settings.
migrateAll `runSqlPool` sqlPool

8
src/Auth/LDAP.hs
View File

@ -44,7 +44,7 @@ findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSet
userSearchSettings = mconcat
[ Ldap.scope ldapScope
, Ldap.size 2
, Ldap.time ldapTimeout
, Ldap.time ldapSearchTimeout
, Ldap.derefAliases Ldap.DerefAlways
]
@ -88,7 +88,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
findUser conf ldap campusIdent [userPrincipalName]
case ldapResult of
Left err
| Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err
| LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
-> do
$logDebugS "LDAP" "Invalid credentials"
loginErrorMessageI LoginR Msg.InvalidLogin
@ -110,7 +110,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
$(widgetFile "widgets/campus-login-form")
data CampusUserException = CampusUserLdapError Ldap.LdapError
data CampusUserException = CampusUserLdapError LdapPoolError
| CampusUserHostNotResolved String
| CampusUserLineTooLong
| CampusUserHostCannotConnect String [IOException]
@ -129,7 +129,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
userSearchSettings = mconcat
[ Ldap.scope Ldap.BaseObject
, Ldap.size 2
, Ldap.time ldapTimeout
, Ldap.time ldapSearchTimeout
, Ldap.derefAliases Ldap.DerefAlways
]
Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []

6
src/CryptoID/TH.hs
View File

@ -6,14 +6,11 @@ import Language.Haskell.TH
import Data.CryptoID.Class.ImplicitNamespace
import Data.UUID.Types (UUID)
import Data.Binary (Binary(..))
import Data.Binary.SerializationLength
import Data.CaseInsensitive (CI)
import System.FilePath (FilePath)
import Database.Persist.Sql (toSqlKey, fromSqlKey)
decCryptoIDs :: [Name] -> DecsQ
decCryptoIDs = fmap concat . mapM decCryptoID
@ -21,9 +18,6 @@ decCryptoIDs = fmap concat . mapM decCryptoID
decCryptoID :: Name -> DecsQ
decCryptoID n@(conT -> t) = do
instances <- [d|
instance Binary $(t) where
get = $(varE 'toSqlKey) <$> get
put = put . $(varE 'fromSqlKey)
instance HasFixedSerializationLength $(t) where
type SerializationLength $(t) = SerializationLength Int64

19
src/Data/CaseInsensitive/Instances.hs
View File

@ -24,6 +24,8 @@ import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJ
import qualified Database.Esqueleto as E
import Web.HttpApiData
instance PersistField (CI Text) where
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@ -75,3 +77,20 @@ instance RenderMessage site a => RenderMessage site (CI a) where
instance Lift t => Lift (CI t) where
lift (CI.original -> orig) = [e|CI.mk $(lift orig)|]
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
fromPathPiece = fmap CI.mk . fromPathPiece
toPathPiece = toPathPiece . CI.original
instance ToHttpApiData (CI Text) where
toUrlPiece = toUrlPiece . CI.original
toEncodedUrlPiece = toEncodedUrlPiece . CI.original
instance FromHttpApiData (CI Text) where
parseUrlPiece = fmap CI.mk . parseUrlPiece
instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
toPathMultiPiece = toPathMultiPiece . CI.foldedCase

25
src/Database/Esqueleto/Instances.hs Normal file
View File

@ -0,0 +1,25 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.Esqueleto.Instances
(
) where
import ClassyPrelude.Yesod
import qualified Database.Esqueleto as E
import Data.Binary (Binary)
import qualified Data.Binary as B
instance ToJSON a => ToJSON (E.Value a) where
toJSON = toJSON . E.unValue
instance FromJSON a => FromJSON (E.Value a) where
parseJSON = fmap E.Value . parseJSON
instance Binary a => Binary (E.Value a) where
put = B.put . E.unValue
get = E.Value <$> B.get
putList = B.putList . map E.unValue

33
src/Database/Persist/Sql/Instances.hs Normal file
View File

@ -0,0 +1,33 @@
{-# 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

13
src/Foundation.hs
View File

@ -1236,14 +1236,19 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemModal = False
, menuItemAccessCallback' = do
now <- liftIO getCurrentTime
[E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet) -> do
sheets <- runDB . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now
E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now
E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return ok
E.orderBy [E.asc $ sheet E.^. SheetActiveFrom]
E.limit 1
return $ sheet E.^. SheetName
case sheets of
(E.Value shn):_ -> (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False
_ -> return False
}
, MenuItem
{ menuItemType = PageActionPrime
@ -1260,7 +1265,7 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
, menuItemModal = False
, menuItemAccessCallback' = do --TODO always show for lecturer
let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False)
let sheetRouteAccess shn = (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False
muid <- maybeAuthId
(sheets,lecturer) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh

20
src/Handler/Corrections.hs
View File

@ -50,8 +50,6 @@ import Data.List (genericLength)
import Control.Monad.Trans.Writer (WriterT(..), runWriter, execWriterT)
import Control.Monad.Trans.Reader (mapReaderT)
import Control.Monad.Trans.RWS (RWST)
import Control.Monad.Trans.State (State, runState)
import qualified Control.Monad.State.Class as State
@ -132,7 +130,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
return $ CSubmissionR tid ssh csh shn cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData)))
colSelect = dbSelect _2 id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
@ -178,23 +176,23 @@ colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_
cell [whamlet|#{review _PseudonymText pseudo}|]
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b))))
colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData)))
colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done))
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b))))
colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } mkUnique -> case sheetType of
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
_other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints)
_other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints)
)
colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text))))
colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
@ -861,7 +859,7 @@ postCorrectionsGradeR = do
, colCommentField
] -- Continue here
psValidator = def
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) = do
cID <- encrypt subId

4
src/Handler/Home.hs
View File

@ -80,7 +80,7 @@ homeAnonymous = do
-- let features = $(widgetFile "featureList")
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
defaultLayout
-- $(widgetFile "dsgvDisclaimer")
-- (widgetFile "dsgvDisclaimer")
$(widgetFile "home")
homeUser :: Key User -> Handler Html
@ -181,7 +181,7 @@ homeUser uid = do
defaultLayout $
-- setTitle "Willkommen zum Uni2work Test!"
$(widgetFile "homeUser")
-- $(widgetFile "dsgvDisclaimer")
-- (widgetFile "dsgvDisclaimer")
getVersionR :: Handler TypedContent

2
src/Handler/Sheet.hs
View File

@ -644,7 +644,7 @@ defaultLoads shid = do
toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
correctorForm :: SheetId -> MForm Handler (FormResult (Bool {- ^ autoDistribute -} , Set SheetCorrector), [FieldView UniWorX])
correctorForm :: SheetId -> MForm Handler (FormResult (Bool, Set SheetCorrector), [FieldView UniWorX])
correctorForm shid = do
cListIdent <- newFormIdent
let

2
src/Handler/Submission.hs
View File

@ -115,7 +115,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
return $ submission E.^. SubmissionId
-- $logDebugS "Submission.DUPLICATENEW" (tshow submissions)
-- logDebugS "Submission.DUPLICATENEW" (tshow submissions)
case submissions of
[] -> do
-- fetch buddies from previous submission in this course

2
src/Handler/SystemMessage.hs
View File

@ -175,7 +175,7 @@ postMessageListR = do
{ dbrOutput = (smE, smT)
, ..
}
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
(tableRes', tableView) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery
, dbtRowKey = (E.^. SystemMessageId)

4
src/Handler/Utils/Form.hs
View File

@ -532,6 +532,10 @@ fsm = bfs -- TODO: get rid of Bootstrap
fsb :: Text -> FieldSettings site -- DEPRECATED
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
fsUniq :: (Text -> Text) -> Text -> FieldSettings site
fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }
optionsPersistCryptoId :: forall site backend a msg.
( YesodPersist site
, PersistQueryRead backend

6
src/Handler/Utils/Submission.hs
View File

@ -64,9 +64,9 @@ instance Exception AssignSubmissionException
-- | Assigns all submissions according to sheet corrector loads
assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
-> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
-> YesodDB UniWorX ( Set SubmissionId -- ^ assigned submissions
, Set SubmissionId -- ^ unassigend submissions (no tutors by load)
)
-> YesodDB UniWorX ( Set SubmissionId
, Set SubmissionId
) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load
assignSubmissions sid restriction = do
Sheet{..} <- getJust sid
correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []

123
src/Handler/Utils/Table/Pagination.hs
View File

@ -3,6 +3,7 @@
module Handler.Utils.Table.Pagination
( module Handler.Utils.Table.Pagination.Types
, SortColumn(..), SortDirection(..)
, SortingSetting(..)
, pattern SortAscBy, pattern SortDescBy
, FilterColumn(..), IsFilterColumn
, DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
@ -10,6 +11,7 @@ module Handler.Utils.Table.Pagination
, DBTable(..), IsDBTable(..), DBCell(..)
, DBParams(..)
, cellAttrs, cellContents
, PagesizeLimit(..)
, PaginationSettings(..), PaginationInput(..), piIsUnset
, PSValidator(..)
, defaultFilter, defaultSorting
@ -67,6 +69,8 @@ import Data.Ratio ((%))
import Control.Lens
import Data.List (elemIndex)
import Data.Aeson (Options(..), SumEncoding(..), defaultOptions)
import Data.Aeson.Text
import Data.Aeson.TH (deriveJSON)
@ -75,6 +79,14 @@ import qualified Data.Text as Text
import Data.Proxy (Proxy(..))
import qualified Data.Binary as B
import qualified Data.ByteArray as BA (convert)
import Crypto.MAC.HMAC (hmac, HMAC)
import Crypto.Hash.Algorithms (SHAKE256)
import qualified Data.ByteString.Base64.URL as Base64 (encode)
import qualified Data.ByteString.Lazy as LBS
$(sqlInTuples [2..16])
@ -82,7 +94,7 @@ $(sqlInTuples [2..16])
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
data SortDirection = SortAsc | SortDesc
deriving (Eq, Ord, Enum, Bounded, Show, Read)
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
instance Universe SortDirection
instance Finite SortDirection
@ -104,7 +116,7 @@ sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
data SortingSetting = SortingSetting
{ sortKey :: SortingKey
, sortDir :: SortDirection
} deriving (Eq, Ord, Show, Read)
} deriving (Eq, Ord, Show, Read, Generic)
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
@ -245,10 +257,12 @@ piIsUnset PaginationInput{..} = and
, isNothing piPage
]
data DBRow r = DBRow
{ dbrOutput :: r
type DBTableKey k' = (ToJSON k', FromJSON k', Ord k', Binary k')
data DBRow r = forall k'. DBTableKey k' => DBRow
{ dbrKey :: k'
, dbrOutput :: r
, dbrIndex, dbrCount :: Int64
} deriving (Show, Read, Eq, Ord)
}
makeLenses_ ''DBRow
@ -259,7 +273,7 @@ instance Foldable DBRow where
foldMap f DBRow{..} = f dbrOutput
instance Traversable DBRow where
traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount
traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrIndex <*> pure dbrCount
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
@ -316,11 +330,12 @@ data DBStyle = DBStyle
{ dbsEmptyStyle :: DBEmptyStyle
, dbsEmptyMessage :: UniWorXMessage
, dbsAttrs :: [(Text, Text)]
, dbsFilterLayout :: Widget -- ^ Filter UI
, dbsFilterLayout :: Widget
-> Enctype
-> Text -- ^ Filter action (target uri)
-> Widget -- ^ Table
-> Text
-> Widget
-> Widget
-- ^ Filter UI, Filter Encoding, Filter action, table
}
instance Default DBStyle where
@ -345,7 +360,7 @@ defaultDBSFilterLayout filterWgdt filterEnctype filterAction scrolltable = $(wid
data DBTable m x = forall a r r' h i t k k'.
( ToSortable h, Functor h
, E.SqlSelect a r, SqlIn k k', ToJSON k', FromJSON k', Eq k'
, E.SqlSelect a r, SqlIn k k', DBTableKey k'
, PathPiece i, Eq i
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
) => DBTable
@ -376,6 +391,9 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x), Default (DBParams m x)) =>
dbHandler :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable m x -> PaginationInput -> [k'] -> m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
dbInvalidateResult :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> DBTableInvalid -> DBResult m x -> m' (DBResult m x)
dbInvalidateResult _ _ _ = return
cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
cellAttrs = dbCell . _1
@ -466,6 +484,12 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment
dbInvalidateResult _ _ reason result = do
reasonTxt <- getMessageRender <*> pure reason
return $ case result of
(FormFailure errs, wdgt) -> (FormFailure $ reasonTxt : errs, wdgt)
(_, wdgt) -> (FormFailure $ pure reasonTxt , wdgt)
instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
def = DBParamsForm
{ dbParamsFormMethod = POST
@ -585,19 +609,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
let
(errs, PaginationSettings{..}) = case piResult of
FormSuccess pi
| not (piIsUnset pi)
-> runPSValidator dbtable $ Just pi
FormFailure errs'
-> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
_ -> runPSValidator dbtable Nothing
paginationInput@PaginationInput{..}
((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
| FormSuccess pi <- piResult
, not $ piIsUnset pi
= pi
= (, pi) . runPSValidator dbtable $ Just pi
| FormFailure errs' <- piResult
= (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
| otherwise
= def
= (, def) $ runPSValidator dbtable Nothing
psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
mapM_ (addMessageI Warning) errs
@ -623,8 +642,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
= succ (psPage * l)
| otherwise
= 1
reproduceSorting
| Just ps <- previousKeys
= sortOn $ \(_, dbrKey, _) -> elemIndex dbrKey ps
| otherwise
= id
(currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) $ zip [firstRow..] rows'
(currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
let
@ -638,13 +662,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
, setParam (wIdent "pagination") Nothing
]
if
| Just pKeys <- previousKeys
, pKeys /= currentKeys
-> redirectWith preconditionFailed412 $ tblLink id
| otherwise
-> return ()
let
rowCount
| (E.Value n, _, _):_ <- rows' = n
@ -690,7 +707,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
uiLayout table = dbsFilterLayout filterWdgt filterEnc rawAction $(widgetFile "table/layout")
bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout) (sendResponse <=< tblLayout . uiLayout <=< dbWidget (Proxy @m) (Proxy @x)) psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table'
dbInvalidateResult' = foldr (<=<) return . catMaybes $
[ do
pKeys <- previousKeys
guard $ pKeys /= currentKeys
return . dbInvalidateResult (Proxy @m) (Proxy @x) . DBTIRowsMissing $ length previousKeys - length currentKeys
]
dbInvalidateResult' <=< bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout) (sendResponse <=< tblLayout . uiLayout <=< dbWidget (Proxy @m) (Proxy @x)) psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table'
where
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
tblLayout tbl' = do
@ -801,25 +825,34 @@ listCell xs mkCell = review dbCell . ([], ) $ do
\(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
return $(widgetFile "table/cell/list")
newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))
newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a))
instance Ord i => Monoid (DBFormResult r i a) where
instance Functor (DBFormResult i a) where
f `fmap` (DBFormResult resMap) = DBFormResult $ fmap (over _1 f) resMap
instance Ord i => Monoid (DBFormResult i a r) where
mempty = DBFormResult Map.empty
(DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
formCell :: forall res r i a. (Ord i, Monoid res)
=> Lens' res (DBFormResult r i a)
-> (r -> MForm (HandlerT UniWorX IO) i)
-> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
-> (r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
formCell resLens genIndex genForm input = FormCell
=> Lens' res (DBFormResult i a (DBRow r))
-> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
formCell resLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
{ formCellAttrs = []
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
i <- genIndex input
(edit, w) <- genForm input i
hashKey <- LBS.toStrict . B.encode <$> cryptoIDKey return
let
mkUnique :: PathPiece p => p -> Text
mkUnique (toPathPiece -> name) = name <> "-" <> decodeUtf8 (Base64.encode rowKeyHash)
where
rowKeyHash = (BA.convert :: HMAC (SHAKE256 264) -> ByteString) . hmac hashKey . LBS.toStrict $ B.encode dbrKey
(edit, w) <- genForm input mkUnique
return (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w)
}
@ -831,10 +864,12 @@ dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r)
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res)
=> Lens' res (DBFormResult r i a)
=> Lens' res (DBFormResult i a (DBRow r))
-> Setter' a Bool
-> (r -> MForm (HandlerT UniWorX IO) i)
-> Colonnade h r (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell resLens genIndex) r $ \_ i -> do
(selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])
-> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
where
genForm _ mkUnique = do
(selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])

13
src/Handler/Utils/Table/Pagination/Types.hs
View File

@ -8,6 +8,7 @@ module Handler.Utils.Table.Pagination.Types
, SortableP(..)
, SqlIn(..)
, sqlInTuples
, DBTableInvalid(..)
) where
import Import hiding (singleton)
@ -28,10 +29,10 @@ import Data.List (foldr1, foldl)
newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
deriving (Show, Read)
deriving (Show, Read, Generic)
deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
newtype SortingKey = SortingKey { _unSortingKey :: CI Text }
deriving (Show, Read)
deriving (Show, Read, Generic)
deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
@ -96,3 +97,11 @@ sqlInTuple arity = do
) []
]
]
data DBTableInvalid = DBTIRowsMissing Int
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Exception DBTableInvalid
embedRenderMessage ''UniWorX ''DBTableInvalid id

5
src/Import/NoFoundation.hs
View File

@ -46,6 +46,8 @@ import Data.Semigroup as Import (Semigroup)
import Data.Monoid as Import (Last(..), First(..))
import Data.Monoid.Instances as Import ()
import Data.Binary as Import (Binary)
import Control.Monad.Morph as Import (MFunctor(..))
import Control.Monad.Trans.Resource as Import (ReleaseKey)
@ -55,6 +57,9 @@ import Yesod.Core.Instances as Import ()
import Ldap.Client.Pool as Import
import Database.Esqueleto.Instances as Import ()
import Database.Persist.Sql.Instances as Import ()
import Control.Monad.Trans.RWS (RWST)

2
src/Jobs.hs
View File

@ -274,7 +274,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
runDB $ delete jId
handleCmd JobCtlDetermineCrontab = do
newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
-- $logDebugS logIdent $ tshow newCTab
-- logDebugS logIdent $ tshow newCTab
mapReaderT (liftIO . atomically) $
lift . void . flip swapTMVar newCTab =<< asks jobCrontab

57
src/Ldap/Client/Pool.hs
View File

@ -3,6 +3,7 @@
module Ldap.Client.Pool
( LdapPool
, LdapExecutor, Ldap, LdapError
, LdapPoolError(..)
, withLdap
, createLdapPool
) where
@ -19,17 +20,24 @@ import Data.Time.Clock (NominalDiffTime)
import Data.Dynamic
import System.Timeout.Lifted
type LdapPool = Pool LdapExecutor
data LdapExecutor = LdapExecutor
{ ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
{ ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError a)
, ldapDestroy :: TMVar ()
}
instance Exception LdapError
data LdapPoolError = LdapPoolTimeout | LdapError LdapError
deriving (Eq, Show, Generic, Typeable)
withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapError a)
instance Exception LdapPoolError
withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapPoolError a)
withLdap pool act = withResource pool $ \LdapExecutor{..} -> liftIO $ ldapExec act
@ -37,10 +45,11 @@ createLdapPool :: ( MonadLoggerIO m, MonadIO m )
=> Ldap.Host
-> Ldap.PortNumber
-> Int -- ^ Stripes
-> NominalDiffTime -- ^ Timeout
-> NominalDiffTime -- ^ Connection Timeout
-> NominalDiffTime -- ^ Action Timeout
-> Int -- ^ Limit
-> m LdapPool
createLdapPool host port stripes timeout limit = do
createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) limit = do
logFunc <- askLoggerIO
let
@ -50,16 +59,17 @@ createLdapPool host port stripes timeout limit = do
ldapAct <- newEmptyTMVarIO
let
ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError a)
ldapExec act = do
ldapAnswer <- newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic))
atomically $ putTMVar ldapAct (fmap toDyn . act, ldapAnswer)
either throwIO (return . Right . flip fromDyn (error "Could not cast dynamic")) =<< atomically (takeTMVar ldapAnswer)
`catches`
[ Handler $ return . Left . Ldap.ParseError
, Handler $ return . Left . Ldap.ResponseError
, Handler $ return . Left . Ldap.IOError
, Handler $ return . Left . Ldap.DisconnectError
[ Handler $ return . Left . LdapError . Ldap.ParseError
, Handler $ return . Left . LdapError . Ldap.ResponseError
, Handler $ return . Left . LdapError . Ldap.IOError
, Handler $ return . Left . LdapError . Ldap.DisconnectError
, Handler $ return . Left . (id :: LdapPoolError -> LdapPoolError)
]
go :: Maybe (TMVar (Maybe a)) -> Ldap -> LoggingT IO ()
@ -71,7 +81,7 @@ createLdapPool host port stripes timeout limit = do
Nothing -> $logDebugS "LdapExecutor" "Terminating"
Just (act, returnRes) -> do
$logDebugS "LdapExecutor" "Executing"
res <- try . liftIO $ act ldap
res <- try . withTimeout . liftIO $ act ldap
didReturn <- atomically $ tryPutTMVar returnRes res
unless didReturn $
$logErrorS "LdapExecutor" "Could not return result"
@ -81,20 +91,25 @@ createLdapPool host port stripes timeout limit = do
]
go Nothing ldap
setup <- newEmptyTMVarIO
void . fork . flip runLoggingT logFunc $ do
$logDebugS "LdapExecutor" "Starting"
res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
case res of
Left exc -> do
$logWarnS "LdapExecutor" $ tshow exc
atomically . void . tryPutTMVar setup $ Just exc
Right res' -> return res'
withTimeout $ do
setup <- newEmptyTMVarIO
maybe (return ()) throwM =<< atomically (takeTMVar setup)
void . fork . flip runLoggingT logFunc $ do
$logDebugS "LdapExecutor" "Starting"
res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
case res of
Left exc -> do
$logWarnS "LdapExecutor" $ tshow exc
atomically . void . tryPutTMVar setup $ Just exc
Right res' -> return res'
maybe (return ()) throwM =<< atomically (takeTMVar setup)
return LdapExecutor{..}
delExecutor :: LdapExecutor -> IO ()
delExecutor LdapExecutor{..} = atomically . void $ tryPutTMVar ldapDestroy ()
liftIO $ createPool mkExecutor delExecutor stripes timeout limit
liftIO $ createPool mkExecutor delExecutor stripes timeoutConn limit
where
withTimeout :: forall m a. (MonadBaseControl IO m, MonadThrow m) => m a -> m a
withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct

2
src/Mail.hs
View File

@ -249,7 +249,7 @@ defMailT ls (MailT mailC) = do
fromAddress <- defaultFromAddress
(ret, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress)
mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
-- $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
-- logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
ret <$ case smtpData of
MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
MailSmtpData{ smtpRecipients }

6
src/Model.hs
View File

@ -22,6 +22,8 @@ import Data.CaseInsensitive.Instances ()
import Utils.Message (MessageClass)
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:
@ -33,5 +35,9 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
deriving instance Eq (Unique Course)
deriving instance Eq (Unique Sheet)
-- 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

28
src/Model/Types.hs
View File

@ -77,37 +77,17 @@ import Data.Data (Data)
import Model.Types.Wordlist
import Data.Text.Metrics (damerauLevenshtein)
import qualified Database.Esqueleto as E
import Data.Binary (Binary)
instance PathPiece UUID where
fromPathPiece = UUID.fromString . unpack
toPathPiece = pack . UUID.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 = toUrlPiece . CI.original
toEncodedUrlPiece = toEncodedUrlPiece . CI.original
instance FromHttpApiData (CI Text) where
parseUrlPiece = fmap CI.mk . parseUrlPiece
instance ToJSON a => ToJSON (E.Value a) where
toJSON = toJSON . E.unValue
instance FromJSON a => FromJSON (E.Value a) where
parseJSON = fmap E.Value . parseJSON
type Count = Sum Integer
type Points = Centi
@ -371,6 +351,8 @@ instance Monoid Load where
data Season = Summer | Winter
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
instance Binary Season
seasonToChar :: Season -> Char
seasonToChar Summer = 'S'
seasonToChar Winter = 'W'
@ -390,6 +372,8 @@ data TermIdentifier = TermIdentifier
, season :: Season
} deriving (Show, Read, Eq, Ord, Generic, Typeable)
instance Binary TermIdentifier
instance Enum TermIdentifier where
-- ^ Do not use for conversion – Enumeration only
toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..}

4
src/Settings.hs
View File

@ -165,7 +165,8 @@ data LdapConf = LdapConf
, ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
, ldapBase :: Ldap.Dn
, ldapScope :: Ldap.Scope
, ldapTimeout :: Int32
, ldapTimeout :: NominalDiffTime
, ldapSearchTimeout :: Int32
, ldapPool :: ResourcePoolConf
} deriving (Show)
@ -253,6 +254,7 @@ instance FromJSON LdapConf where
ldapBase <- Ldap.Dn <$> o .: "baseDN"
ldapScope <- o .: "scope"
ldapTimeout <- o .: "timeout"
ldapSearchTimeout <- o .: "search-timeout"
ldapPool <- o .: "pool"
return LdapConf{..}

11
test/Handler/CorrectionsSpec.hs Normal file
View File

@ -0,0 +1,11 @@
module Handler.CorrectionsSpec where
import TestImport
import ModelSpec ()
spec :: Spec
spec = withApp $ do
describe "CorrectionsR" $ do
return ()

22
test/Handler/Utils/Table/Pagination/TypesSpec.hs Normal file
View File

@ -0,0 +1,22 @@
module Handler.Utils.Table.Pagination.TypesSpec where
import TestImport
import Handler.Utils.Table.Pagination.Types
instance Arbitrary FilterKey where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary SortingKey where
arbitrary = genericArbitrary
shrink = genericShrink
spec :: Spec
spec = do
parallel $ do
lawsCheckHspec (Proxy @FilterKey)
[ eqLaws, ordLaws, showReadLaws, pathPieceLaws, jsonLaws, jsonKeyLaws ]
lawsCheckHspec (Proxy @SortingKey)
[ eqLaws, ordLaws, showReadLaws, pathPieceLaws, jsonLaws, jsonKeyLaws ]

43
test/Handler/Utils/Table/PaginationSpec.hs Normal file
View File

@ -0,0 +1,43 @@
module Handler.Utils.Table.PaginationSpec where
import TestImport
import Handler.Utils.Table.Pagination
import Handler.Utils.Table.Pagination.TypesSpec ()
import Data.Aeson (encode)
instance Arbitrary SortDirection where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary SortingSetting where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary PaginationInput where
arbitrary = scale (`div` 2) genericArbitrary
shrink = genericShrink
instance Arbitrary PagesizeLimit where
arbitrary = oneof
[ pure PagesizeAll
, PagesizeLimit . getNonNegative <$> arbitrary
]
shrink = genericShrink
spec :: Spec
spec = do
parallel $ do
lawsCheckHspec (Proxy @SortDirection)
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, pathPieceLaws, finiteLaws, jsonLaws ]
lawsCheckHspec (Proxy @SortingSetting)
[ eqLaws, ordLaws, showReadLaws, jsonLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @PaginationInput)
[ eqLaws, ordLaws, showReadLaws, jsonLaws ]
lawsCheckHspec (Proxy @PagesizeLimit)
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, pathPieceLaws, jsonLaws ]
describe "PaginationInput" $ do
it "is unset iff it encodes to {}" . property $ \inp -> piIsUnset inp == (encode inp == "{}")

23
test/Handler/Utils/ZipSpec.hs
View File

@ -4,22 +4,15 @@ import TestImport
import Handler.Utils.Zip
import System.FilePath
import Data.Conduit
import qualified Data.Conduit.List as Conduit
import Data.List (dropWhileEnd)
import Data.Time
instance Arbitrary File where
arbitrary = do
fileTitle <- (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
fileContent <- arbitrary
return File{..}
shrink = genericShrink
import ModelSpec ()
import System.FilePath
import Data.Time
spec :: Spec
spec = describe "Zip file handling" $ do
@ -34,11 +27,3 @@ spec = describe "Zip file handling" $ do
(shouldBe `on` acceptableFilenameChanges) (fileTitle file') (fileTitle file)
(fileModified file', fileModified file) `shouldSatisfy` uncurry acceptableTimeDifference
(fileContent file') `shouldBe` (fileContent file)
inZipRange :: UTCTime -> Bool
inZipRange time
| time > UTCTime (fromGregorian 1980 1 1) 0
, time < UTCTime (fromGregorian 2107 1 1) 0
= True
| otherwise
= False

19
test/MailSpec.hs
View File

@ -10,7 +10,7 @@ instance Arbitrary MailSmtpData where
shrink = genericShrink
instance Arbitrary MailLanguages where
arbitrary = MailLanguages <$> arbitrary
arbitrary = fmap MailLanguages $ shuffle =<< sublistOf (toList appLanguages)
shrink = genericShrink
instance Arbitrary MailContext where
@ -23,11 +23,12 @@ instance Arbitrary VerpMode where
spec :: Spec
spec = do
lawsCheckHspec (Proxy @MailSmtpData)
[ eqLaws, ordLaws, showReadLaws, monoidLaws ]
lawsCheckHspec (Proxy @MailLanguages)
[ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
lawsCheckHspec (Proxy @MailContext)
[ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
lawsCheckHspec (Proxy @VerpMode)
[ eqLaws, showReadLaws, jsonLaws ]
parallel $ do
lawsCheckHspec (Proxy @MailSmtpData)
[ eqLaws, ordLaws, showReadLaws, monoidLaws ]
lawsCheckHspec (Proxy @MailLanguages)
[ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
lawsCheckHspec (Proxy @MailContext)
[ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
lawsCheckHspec (Proxy @VerpMode)
[ eqLaws, showReadLaws, jsonLaws ]

131
test/Model/TypesSpec.hs
View File

@ -1,6 +1,7 @@
module Model.TypesSpec where
import TestImport
import Settings
import Control.Lens (review, preview)
import Data.Aeson (Value)
@ -8,6 +9,9 @@ import qualified Data.Aeson as Aeson
import MailSpec ()
import System.IO.Unsafe
import Yesod.Auth.Util.PasswordStore
instance Arbitrary Season where
arbitrary = genericArbitrary
@ -89,10 +93,6 @@ instance Arbitrary CorrectorState where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary AuthenticationMode where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary NotificationTrigger where
arbitrary = genericArbitrary
shrink = genericShrink
@ -126,64 +126,79 @@ instance Arbitrary Value where
arbitrary' :: forall a. Arbitrary a => Gen a
arbitrary' = scale (`div` 2) arbitrary
shrink = genericShrink
instance Arbitrary AuthenticationMode where
arbitrary = oneof
[ pure AuthLDAP
, do
pw <- encodeUtf8 . pack . getPrintableString <$> arbitrary
let
PWHashConf{..} = appAuthPWHash compileTimeAppSettings
authPWHash = unsafePerformIO . fmap decodeUtf8 $ makePasswordWith pwHashAlgorithm pw (pwHashStrength `div` 2)
return $ AuthPWHash{..}
]
shrink AuthLDAP = []
shrink (AuthPWHash _) = [AuthLDAP]
spec :: Spec
spec = do
lawsCheckHspec (Proxy @UUID)
[ persistFieldLaws, pathPieceLaws, eqLaws, ordLaws, showReadLaws, hashableLaws, jsonLaws, storableLaws, jsonKeyLaws, httpApiDataLaws ]
lawsCheckHspec (Proxy @FilePath)
[ pathMultiPieceLaws ]
lawsCheckHspec (Proxy @(CI Text))
[ httpApiDataLaws ]
lawsCheckHspec (Proxy @SheetGrading)
[ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @SheetGradeSummary)
[ eqLaws, showReadLaws, commutativeMonoidLaws, commutativeSemigroupLaws ]
lawsCheckHspec (Proxy @SheetType)
[ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @SheetTypeSummary)
[ eqLaws, showReadLaws, commutativeMonoidLaws ]
lawsCheckHspec (Proxy @SheetGroup)
[ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @SheetFileType)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
lawsCheckHspec (Proxy @SubmissionFileType)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
lawsCheckHspec (Proxy @UploadMode)
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
lawsCheckHspec (Proxy @SheetSubmissionMode)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, finiteLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @ExamStatus)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @Load)
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
lawsCheckHspec (Proxy @Season)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
lawsCheckHspec (Proxy @TermIdentifier)
[ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @StudyFieldType)
[ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @Theme)
[ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @CorrectorState)
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @AuthenticationMode)
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @Value)
[ persistFieldLaws ]
lawsCheckHspec (Proxy @NotificationTrigger)
[ 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)
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
lawsCheckHspec (Proxy @AuthTagActive)
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
parallel $ do
lawsCheckHspec (Proxy @UUID)
[ persistFieldLaws, pathPieceLaws, eqLaws, ordLaws, showReadLaws, hashableLaws, jsonLaws, storableLaws, jsonKeyLaws, httpApiDataLaws ]
lawsCheckHspec (Proxy @FilePath)
[ pathMultiPieceLaws ]
lawsCheckHspec (Proxy @(CI Text))
[ httpApiDataLaws ]
lawsCheckHspec (Proxy @SheetGrading)
[ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @SheetGradeSummary)
[ eqLaws, showReadLaws, commutativeMonoidLaws, commutativeSemigroupLaws ]
lawsCheckHspec (Proxy @SheetType)
[ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @SheetTypeSummary)
[ eqLaws, showReadLaws, commutativeMonoidLaws ]
lawsCheckHspec (Proxy @SheetGroup)
[ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @SheetFileType)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
lawsCheckHspec (Proxy @SubmissionFileType)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
lawsCheckHspec (Proxy @UploadMode)
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
lawsCheckHspec (Proxy @SheetSubmissionMode)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, finiteLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @ExamStatus)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @Load)
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
lawsCheckHspec (Proxy @Season)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
lawsCheckHspec (Proxy @TermIdentifier)
[ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @StudyFieldType)
[ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @Theme)
[ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @CorrectorState)
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @AuthenticationMode)
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @Value)
[ persistFieldLaws ]
lawsCheckHspec (Proxy @NotificationTrigger)
[ 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)
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
lawsCheckHspec (Proxy @AuthTagActive)
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
describe "TermIdentifier" $ do
it "has compatible encoding/decoding to/from Text" . property $

107
test/ModelSpec.hs Normal file
View File

@ -0,0 +1,107 @@
module ModelSpec where
import TestImport
import Model.TypesSpec ()
import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString.Char8 as CBS
import Text.Email.Validate (emailAddress, EmailAddress)
import qualified Text.Email.Validate as Email (isValid, toByteString)
import qualified Data.Set as Set
import Handler.Utils.DateTime
import qualified Data.Text as Text
import qualified Data.Char as Char
import Utils
import System.FilePath
import Data.Time
instance Arbitrary EmailAddress where
arbitrary = do
local <- suchThat arbitrary (\l -> isEmail l (CBS.pack "example.com"))
domain <- suchThat arbitrary (\d -> isEmail (CBS.pack "example") d)
let (Just result) = emailAddress (makeEmailLike local domain)
pure result
where
isEmail l d = Email.isValid (makeEmailLike l d)
makeEmailLike l d = CBS.concat [l, CBS.singleton '@', d]
instance Arbitrary User where
arbitrary = do
userIdent <- CI.mk . pack <$> oneof
[ getPrintableString <$> arbitrary
, on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary
]
userAuthentication <- arbitrary
userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
userEmail <- CI.mk . decodeUtf8 . Email.toByteString <$> arbitrary
names <- listOf1 $ pack . getPrintableString <$> arbitrary
userDisplayName <- unwords <$> sublistOf names
userSurname <- unwords <$> sublistOf names
userMaxFavourites <- getNonNegative <$> arbitrary
userTheme <- arbitrary
let genDateTimeFormat sel = do
timeLocale <- elements . map getTimeLocale' . pure $ toList appLanguages
elements . Set.toList $ validDateTimeFormats timeLocale sel
userDateTimeFormat <- genDateTimeFormat SelFormatDateTime
userDateFormat <- genDateTimeFormat SelFormatDate
userTimeFormat <- genDateTimeFormat SelFormatTime
userDownloadFiles <- arbitrary
userMailLanguages <- arbitrary
userNotificationSettings <- arbitrary
return User{..}
shrink = genericShrink
instance Arbitrary File where
arbitrary = do
fileTitle <- scale (`div` 2) $ (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
fileContent <- arbitrary
return File{..}
where
inZipRange :: UTCTime -> Bool
inZipRange time
| time > UTCTime (fromGregorian 1980 1 1) 0
, time < UTCTime (fromGregorian 2107 1 1) 0
= True
| otherwise
= False
shrink = genericShrink
instance Arbitrary School where
arbitrary = do
names <- listOf1 $ pack . getPrintableString <$> arbitrary
let
name = Text.toTitle $ unwords names
schoolShorthand = CI.mk $ Text.filter Char.isUpper name
schoolName = CI.mk name
return School{..}
instance Arbitrary Term where
arbitrary = genericArbitrary
shrink = genericShrink
spec :: Spec
spec = do
parallel $ do
lawsCheckHspec (Proxy @User)
[ eqLaws, jsonLaws ]
lawsCheckHspec (Proxy @File)
[ eqLaws ]
lawsCheckHspec (Proxy @School)
[ eqLaws ]
lawsCheckHspec (Proxy @Term)
[ eqLaws, jsonLaws ]

2
test/TestImport.hs
View File

@ -122,7 +122,7 @@ createUser adjUser = do
runDB . insertEntity $ adjUser User{..}
lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec
lawsCheckHspec p = describe (show $ typeRep p) . mapM_ (checkHspec . ($ p))
lawsCheckHspec p = parallel . describe (show $ typeRep p) . mapM_ (checkHspec . ($ p))
where
checkHspec (Laws className properties) = describe className $
forM_ properties $ \(name, prop) -> it name $ property prop

9
test/Utils/DateTimeSpec.hs
View File

@ -14,7 +14,8 @@ instance CoArbitrary SelDateTimeFormat where
spec :: Spec
spec = do
lawsCheckHspec (Proxy @DateTimeFormat)
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, hashableLaws ]
lawsCheckHspec (Proxy @SelDateTimeFormat)
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
parallel $ do
lawsCheckHspec (Proxy @DateTimeFormat)
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, hashableLaws ]
lawsCheckHspec (Proxy @SelDateTimeFormat)
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]