201 lines
9.0 KiB
Haskell
201 lines
9.0 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
|
|
{-# OPTIONS -Wno-unused-imports #-} -- TODO: remove me, for debugging only
|
|
|
|
module Handler.LMS.Userlist
|
|
( getLmsUserlistR, postLmsUserlistR
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Csv
|
|
import Handler.Utils.LMS
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Csv as Csv
|
|
import qualified Data.Conduit.List as C
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
data LmsUserlistTableCsv = LmsUserlistTableCsv
|
|
{ csvLULident :: LmsIdent
|
|
, csvLULfailed :: Bool
|
|
}
|
|
deriving Generic
|
|
makeLenses_ ''LmsUserlistTableCsv
|
|
|
|
-- csv without headers -- TODO not yet supported
|
|
instance Csv.ToRecord LmsUserlistTableCsv
|
|
instance Csv.FromRecord LmsUserlistTableCsv
|
|
|
|
-- csv with headers
|
|
lmsUserlistTableCsvHeader :: Csv.Header
|
|
lmsUserlistTableCsvHeader = Csv.header [ csvUserlistIdent, csvUserlistBlocked ]
|
|
|
|
instance ToNamedRecord LmsUserlistTableCsv where
|
|
toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
|
|
[ csvUserlistIdent Csv..= csvLULident
|
|
, csvUserlistBlocked Csv..= csvLULfailed
|
|
]
|
|
instance FromNamedRecord LmsUserlistTableCsv where
|
|
parseNamedRecord (lsfHeaderTranslate -> csv)
|
|
= LmsUserlistTableCsv
|
|
<$> csv Csv..: csvUserlistIdent
|
|
<*> csv Csv..: csvUserlistBlocked
|
|
|
|
instance CsvColumnsExplained LmsUserlistTableCsv where
|
|
csvColumnsExplanations _ = mconcat
|
|
[ single csvUserlistIdent MsgCsvColumnLmsIdent
|
|
, single csvUserlistBlocked MsgCsvColumnLmsFailed
|
|
]
|
|
where
|
|
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
|
|
single k v = singletonMap k [whamlet|_{v}|]
|
|
|
|
|
|
data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
|
|
embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id
|
|
|
|
data LmsUserlistCsvAction = LmsUserlistInsertData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool }
|
|
| LmsUserlistUpdateData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool }
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece'' 2 1 -- LmsUserlistInsertData -> insert
|
|
, fieldLabelModifier = camelToPathPiece' 2 -- lmsUserlistInsertIdent -> insert-ident | lmsUserlistInsertFailed -> insert-failed
|
|
, sumEncoding = TaggedObject "action" "data"
|
|
} ''LmsUserlistCsvAction
|
|
|
|
|
|
data LmsUserlistCsvException
|
|
= LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
|
|
deriving (Show, Generic, Typeable)
|
|
|
|
instance Exception LmsUserlistCsvException
|
|
embedRenderMessage ''UniWorX ''LmsUserlistCsvException id
|
|
|
|
mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
|
mkUserlistTable sid qsh qid = do
|
|
dbtCsvName <- csvFilenameLmsUserlist qsh
|
|
let dbtCsvSheetName = dbtCsvName
|
|
let
|
|
userlistTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery lmslist = do
|
|
E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
|
|
return lmslist
|
|
dbtRowKey = (E.^. LmsUserlistId)
|
|
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ sortable (Just csvUserlistIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent
|
|
, sortable (Just csvUserlistBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> isBadCell lmsUserlistFailed
|
|
, sortable (Just "timestamp") (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ (csvUserlistIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
|
|
, (csvUserlistBlocked, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
|
|
, ("timestamp" , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ (csvUserlistIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
|
|
, (csvUserlistBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed))
|
|
]
|
|
dbtFilterUI = \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter csvUserlistIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
|
|
, prismAForm (singletonFilter csvUserlistBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
|
|
]
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "lms-userlist"
|
|
dbtCsvEncode = Just DBTCsvEncode {..}
|
|
where
|
|
dbtCsvExportForm = pure ()
|
|
dbtCsvNoExportData = Just id
|
|
dbtCsvExampleData = Nothing
|
|
dbtCsvHeader = const $ return lmsUserlistTableCsvHeader
|
|
dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
|
|
doEncode' = LmsUserlistTableCsv
|
|
<$> view (_dbrOutput . _entityVal . _lmsUserlistIdent)
|
|
<*> view (_dbrOutput . _entityVal . _lmsUserlistFailed)
|
|
dbtCsvDecode = Just DBTCsvDecode {..}
|
|
where
|
|
dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} ->
|
|
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident
|
|
dbtCsvComputeActions = \case -- shows a diff first
|
|
DBCsvDiffNew{dbCsvNew} -> do
|
|
yield $ LmsUserlistInsertData
|
|
{ lmsUserlistInsertIdent = csvLULident dbCsvNew
|
|
, lmsUserlistInsertFailed = csvLULfailed dbCsvNew
|
|
}
|
|
DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}} -> do
|
|
yield $ LmsUserlistUpdateData
|
|
{ lmsUserlistInsertIdent = csvLULident
|
|
, lmsUserlistInsertFailed = csvLULfailed
|
|
}
|
|
DBCsvDiffMissing{} -> return () -- no deletion
|
|
dbtCsvClassifyAction = \case
|
|
LmsUserlistInsertData{} -> LmsUserlistInsert
|
|
LmsUserlistUpdateData{} -> LmsUserlistUpdate
|
|
dbtCsvCoarsenActionClass = \case
|
|
LmsUserlistInsert -> DBCsvActionNew
|
|
LmsUserlistUpdate -> DBCsvActionExisting
|
|
dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error
|
|
dbtCsvExecuteActions = do
|
|
C.mapM_ $ \actionData -> do
|
|
now <- liftIO getCurrentTime
|
|
void $ upsert LmsUserlist
|
|
{
|
|
lmsUserlistQualification = qid
|
|
, lmsUserlistIdent = lmsUserlistInsertIdent actionData
|
|
, lmsUserlistFailed = lmsUserlistInsertFailed actionData
|
|
, lmsUserlistTimestamp = now
|
|
}
|
|
[
|
|
LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False?
|
|
, LmsUserlistTimestamp =. now
|
|
]
|
|
return $ LmsUserlistR sid qsh
|
|
dbtCsvRenderKey = const $ \case
|
|
LmsUserlistInsertData{..} -> do -- TODO: i18n
|
|
[whamlet|
|
|
$newline never
|
|
Insert: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} #
|
|
$if lmsUserlistInsertFailed
|
|
is closed due to failure.
|
|
$else
|
|
is open.
|
|
|]
|
|
LmsUserlistUpdateData{..} -> do -- TODO: i18n
|
|
[whamlet|
|
|
$newline never
|
|
Update: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} #
|
|
$if lmsUserlistInsertFailed
|
|
is now closed due to failure.
|
|
$else
|
|
is still open.
|
|
|]
|
|
dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
|
dbtCsvRenderException = ap getMessageRender . pure :: LmsUserlistCsvException -> DB Text
|
|
dbtExtraReps = []
|
|
|
|
userlistDBTableValidator = def
|
|
& defaultSorting [SortAscBy csvUserlistIdent]
|
|
|
|
dbTable userlistDBTableValidator userlistTable
|
|
|
|
|
|
getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsUserlistR = postLmsUserlistR
|
|
postLmsUserlistR sid qsh = do
|
|
lmsTable <- runDB $ do
|
|
qid <- getKeyBy404 $ UniqueSchoolShort sid qsh
|
|
view _2 <$> mkUserlistTable sid qsh qid
|
|
siteLayoutMsg MsgMenuLmsUserlist $ do
|
|
setTitleI MsgMenuLmsUserlist
|
|
$(widgetFile "lms-userlist")
|