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

Fix some hlint

Browse Source
This commit is contained in:
Gregor Kleen 2018-11-02 00:25:44 +01:00
parent 9ccc2e3149
commit e5d3213efb
23 changed files with 154 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.hlint.yaml Normal file
View File

@ -0,0 +1,12 @@
# HLint configuration file
# https://github.com/ndmitchell/hlint
##########################
- ignore: { name: "Parse error" }
- ignore: { name: "Reduce duplication" }
- ignore: { name: "Use ||" }
- arguments:
- -XQuasiQuotes
- -XTemplateHaskell
- -j

5
hlint/Hlint.hs
View File

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

16
src/Handler/SystemMessage.hs
View File

@ -72,7 +72,7 @@ postMessageR cID = do
formResult addTransRes addTranslation formResult addTransRes addTranslation
forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, (catMaybes -> acts)) -> case acts of forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, catMaybes -> acts) -> case acts of
[BtnDelete'] -> do [BtnDelete'] -> do
runDB $ delete tId runDB $ delete tId
addMessageI Success MsgSystemMessageDeleteTranslationSuccess addMessageI Success MsgSystemMessageDeleteTranslationSuccess
@ -111,7 +111,7 @@ postMessageR cID = do
maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
forms <- traverse (const mkForm) $ () <$ guard maySubmit forms <- traverse (const mkForm) $ () <$ guard maySubmit
defaultLayout $ do defaultLayout $
$(widgetFile "system-message") $(widgetFile "system-message")
where where
modifySystemMessage smId SystemMessage{..} = do modifySystemMessage smId SystemMessage{..} = do
@ -162,7 +162,7 @@ postMessageListR = do
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId [ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
, dbRow , dbRow
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) (\cID -> MessageR cID) (toWidget . tshow . ciphertext) , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext)
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
, sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
, sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
@ -175,12 +175,12 @@ postMessageListR = do
] ]
dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
Just (_, smT) <- lift $ getSystemMessage appLanguages smId Just (_, smT) <- lift $ getSystemMessage appLanguages smId
return $ DBRow return DBRow
{ dbrOutput = (smE, smT) { dbrOutput = (smE, smT)
, .. , ..
} }
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool)) psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
tableForm <- dbTable psValidator $ DBTable tableForm <- dbTable psValidator DBTable
{ dbtSQLQuery { dbtSQLQuery
, dbtColonnade , dbtColonnade
, dbtProj , dbtProj
@ -194,8 +194,8 @@ postMessageListR = do
, dbtIdent = "messages" :: Text , dbtIdent = "messages" :: Text
} }
((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do ((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
now <- liftIO $ getCurrentTime now <- liftIO getCurrentTime
let actions = Map.fromList let actions = Map.fromList
[ (SMDelete, pure SMDDelete) [ (SMDelete, pure SMDDelete)
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now)) , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
@ -248,5 +248,5 @@ postMessageListR = do
addMessageI Success $ MsgSystemMessageAdded cID addMessageI Success $ MsgSystemMessageAdded cID
redirect $ MessageR cID redirect $ MessageR cID
defaultLayout $ do defaultLayout $
$(widgetFile "system-message-list") $(widgetFile "system-message-list")

14
src/Handler/Term.hs
View File

@ -13,7 +13,7 @@ import qualified Database.Esqueleto as E
validateTerm :: Term -> [Text] validateTerm :: Term -> [Text]
validateTerm (Term{..}) = validateTerm Term{..} =
[ msg | (False, msg) <- [ msg | (False, msg) <-
[ --startOk [ --startOk
( termStart `withinTerm` termName ( termStart `withinTerm` termName
@ -68,7 +68,7 @@ getTermShowR = do
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
cell $ formatTime SelFormatDate termLectureEnd >>= toWidget cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
, sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) -> , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
textCell $ (bool "" tickmark termActive :: Text) textCell (bool "" tickmark termActive :: Text)
, sortable Nothing "Kurse" $ \(_, E.Value numCourses) -> , sortable Nothing "Kurse" $ \(_, E.Value numCourses) ->
cell [whamlet|_{MsgNumCourses numCourses}|] cell [whamlet|_{MsgNumCourses numCourses}|]
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
@ -96,7 +96,7 @@ getTermShowR = do
-- #{termToText termName} -- #{termToText termName}
-- |] -- |]
-- ] -- ]
((), table) <- dbTable def $ DBTable ((), table) <- dbTable def DBTable
{ dbtSQLQuery = termData { dbtSQLQuery = termData
, dbtColonnade = colonnadeTerms , dbtColonnade = colonnadeTerms
, dbtProj = return . dbrOutput , dbtProj = return . dbrOutput
@ -116,12 +116,12 @@ getTermShowR = do
] ]
, dbtFilter = Map.fromList , dbtFilter = Map.fromList
[ ( "active" [ ( "active"
, FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool)) , FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool)
) )
, ( "course" , ( "course"
, FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
[] -> E.val True :: E.SqlExpr (E.Value Bool) [] -> E.val True :: E.SqlExpr (E.Value Bool)
cshs -> E.exists . E.from $ \course -> do cshs -> E.exists . E.from $ \course ->
E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
) )
@ -134,7 +134,7 @@ getTermShowR = do
$(widgetFile "terms") $(widgetFile "terms")
getTermEditR :: Handler Html getTermEditR :: Handler Html
getTermEditR = do getTermEditR =
-- TODO: Defaults für Semester hier ermitteln und übergeben -- TODO: Defaults für Semester hier ermitteln und übergeben
termEditHandler Nothing termEditHandler Nothing
@ -162,7 +162,7 @@ termEditHandler term = do
-- MIT INTERNATIONALISIERUNG: -- MIT INTERNATIONALISIERUNG:
addMessageI Success $ MsgTermEdited tid addMessageI Success $ MsgTermEdited tid
redirect TermShowR redirect TermShowR
(FormMissing ) -> return () FormMissing -> return ()
(FormFailure _) -> addMessageI Warning MsgInvalidInput (FormFailure _) -> addMessageI Warning MsgInvalidInput
let actionUrl = TermEditR let actionUrl = TermEditR
defaultLayout $ do defaultLayout $ do

4
src/Handler/Users.hs
View File

@ -69,7 +69,7 @@ getUsersR = do
psValidator = def psValidator = def
& defaultSorting [("name", SortAsc),("display-name", SortAsc)] & defaultSorting [("name", SortAsc),("display-name", SortAsc)]
((), userList) <- dbTable psValidator $ DBTable ((), userList) <- dbTable psValidator DBTable
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
, dbtColonnade , dbtColonnade
, dbtProj = return , dbtProj = return
@ -106,7 +106,7 @@ postAdminHijackUserR cID = do
otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
mySchools <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] [] mySchools <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
when (not $ (otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $ unless ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
permissionDenied "Cannot escalate admin status to additional schools" permissionDenied "Cannot escalate admin status to additional schools"
get404 uid get404 uid

2
src/Handler/Utils.hs
View File

@ -31,7 +31,7 @@ downloadFiles = do
return userDefaultDownloadFiles return userDefaultDownloadFiles
tidFromText :: Text -> Maybe TermId tidFromText :: Text -> Maybe TermId
tidFromText = (fmap TermKey) . maybeRight . termFromText tidFromText = fmap TermKey . maybeRight . termFromText
simpleLink :: Widget -> Route UniWorX -> Widget simpleLink :: Widget -> Route UniWorX -> Widget
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|] simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]

10
src/Handler/Utils/DateTime.hs
View File

@ -10,7 +10,7 @@ module Handler.Utils.DateTime
import Import import Import
import Data.Time.Zones hiding (localTimeToUTCFull) import Data.Time.Zones
import qualified Data.Time.Zones as TZ import qualified Data.Time.Zones as TZ
import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime) import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
@ -36,7 +36,7 @@ instance HasLocalTime Day where
toLocalTime d = LocalTime d midnight toLocalTime d = LocalTime d midnight
instance HasLocalTime UTCTime where instance HasLocalTime UTCTime where
toLocalTime t = utcToLocalTime t toLocalTime = utcToLocalTime
formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t) formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
@ -78,7 +78,7 @@ getDateTimeFormat sel = do
validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat
-- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon -- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon
validDateTimeFormats _ SelFormatDateTime = Set.fromList $ validDateTimeFormats _ SelFormatDateTime = Set.fromList
[ DateTimeFormat "%a %d %b %Y %R" [ DateTimeFormat "%a %d %b %Y %R"
, DateTimeFormat "%a %b %d %Y %R" , DateTimeFormat "%a %b %d %Y %R"
, DateTimeFormat "%A, %d %B %Y %R" , DateTimeFormat "%A, %d %B %Y %R"
@ -95,7 +95,7 @@ validDateTimeFormats _ SelFormatDateTime = Set.fromList $
, DateTimeFormat "%Y-%m-%d %T" , DateTimeFormat "%Y-%m-%d %T"
, DateTimeFormat "%Y-%m-%dT%T" , DateTimeFormat "%Y-%m-%dT%T"
] ]
validDateTimeFormats _ SelFormatDate = Set.fromList $ validDateTimeFormats _ SelFormatDate = Set.fromList
[ DateTimeFormat "%a %d %b %Y" [ DateTimeFormat "%a %d %b %Y"
, DateTimeFormat "%a %b %d %Y" , DateTimeFormat "%a %b %d %Y"
, DateTimeFormat "%A, %d %B %Y" , DateTimeFormat "%A, %d %B %Y"
@ -126,7 +126,7 @@ dateTimeFormatOptions sel = do
let let
toOption fmt@DateTimeFormat{..} = do toOption fmt@DateTimeFormat{..} = do
dateTime <- formatTime' unDateTimeFormat now dateTime <- formatTime' unDateTimeFormat now
return $ (dateTime, fmt) return (dateTime, fmt)
optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel

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

@ -131,7 +131,7 @@ buttonForm csrf = do
buttonIdent <- newFormIdent buttonIdent <- newFormIdent
let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
(results, btnViews) <- unzip <$> mapM button [minBound..maxBound] (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
let widget = do let widget =
[whamlet| [whamlet|
#{csrf} #{csrf}
$forall bView <- btnViews $forall bView <- btnViews
@ -163,16 +163,16 @@ natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMess
natFieldI msg = checkBool (>= 0) msg intField natFieldI msg = checkBool (>= 0) msg intField
natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") $ intField natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") intField
natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
natIntField = natField natIntField = natField
posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") $ intField posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") intField
minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField
pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions
pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
@ -252,7 +252,7 @@ zipFileField doUnpack = Field{..}
| [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f | [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
| null files = return $ Right Nothing | null files = return $ Right Nothing
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile | otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
fieldView fieldId fieldName attrs _ req = do fieldView fieldId fieldName attrs _ req =
[whamlet| [whamlet|
$newline never $newline never
<input type=file ##{fieldId} *{attrs} name=#{fieldName} :req:required> <input type=file ##{fieldId} *{attrs} name=#{fieldName} :req:required>
@ -450,7 +450,7 @@ utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing) -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
-- Browser returns LocalTime -- Browser returns LocalTime
utcTimeField = Field utcTimeField = Field
{ fieldParse = parseHelperGen $ readTime { fieldParse = parseHelperGen readTime
, fieldView = \theId name attrs val isReq -> do , fieldView = \theId name attrs val isReq -> do
val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
[whamlet| [whamlet|
@ -468,10 +468,10 @@ utcTimeField = Field
readTime :: Text -> Either UniWorXMessage UTCTime readTime :: Text -> Either UniWorXMessage UTCTime
readTime t = readTime t =
case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
(Just (LTUUnique time _)) -> Right time Just LTUUnique{_ltuResult} -> Right _ltuResult
(Just (LTUNone _ _)) -> Left MsgIllDefinedUTCTime Just LTUNone{} -> Left MsgIllDefinedUTCTime
(Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime Just LTUAmbiguous{} -> Left MsgAmbiguousUTCTime
Nothing -> Left MsgInvalidDateTimeFormat Nothing -> Left MsgInvalidDateTimeFormat
langField :: Bool -- ^ Only allow values from `appLanguages` langField :: Bool -- ^ Only allow values from `appLanguages`
-> Field (HandlerT UniWorX IO) Lang -> Field (HandlerT UniWorX IO) Lang
@ -547,13 +547,13 @@ apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
-- ^ Pseudo required -- ^ Pseudo required
apreq f fs mx = formToAForm $ do apreq f fs mx = formToAForm $ do
mr <- getMessageRender mr <- getMessageRender
fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } ))) $ mopt f fs (Just <$> mx) over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
=> Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a) => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
wpreq f fs mx = mFormToWForm $ do wpreq f fs mx = mFormToWForm $ do
mr <- getMessageRender mr <- getMessageRender
fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } )) $ mopt f fs (Just <$> mx) over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a) => Map action (AForm (HandlerT UniWorX IO) a)

12
src/Handler/Utils/Rating.hs
View File

@ -13,7 +13,7 @@ module Handler.Utils.Rating
, extractRatings , extractRatings
) where ) where
import Import hiding ((</>)) import Import
import Text.PrettyPrint.Leijen.Text hiding ((<$>)) import Text.PrettyPrint.Leijen.Text hiding ((<$>))
@ -56,9 +56,9 @@ instance Pretty x => Pretty (CI x) where
instance Pretty SheetGrading where instance Pretty SheetGrading where
pretty (Points {..}) = pretty ( (show maxPoints) <> " Punkte" :: String) pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String)
pretty (PassPoints {..}) = pretty ( (show maxPoints) <> " Punkte, bestanden ab " <> (show passingPoints) <> " Punkte" :: String ) pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String )
pretty (PassBinary) = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String ) pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
data Rating = Rating data Rating = Rating
@ -138,10 +138,10 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc
ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File
ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
fileModified <- maybe (liftIO getCurrentTime) return ratingTime fileModified <- maybe (liftIO getCurrentTime) return ratingTime
let let
fileTitle = "bewertung_" <> (Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)) <.> "txt" fileTitle = "bewertung_" <> Text.unpack (toPathPiece cID) <.> "txt"
fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
return File{..} return File{..}

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

@ -37,8 +37,8 @@ pKey :: Parser Int
pKey = decimal pKey = decimal
pType :: Parser StudyFieldType pType :: Parser StudyFieldType
pType = FieldPrimary <$ (try $ string "HF") pType = FieldPrimary <$ try (string "HF")
<|> FieldSecondary <$ (try $ string "NF") <|> FieldSecondary <$ try (string "NF")
decimal :: Parser Int decimal :: Parser Int
decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit' decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'

7
src/Handler/Utils/Table.hs
View File

@ -1,8 +1,7 @@
module Handler.Utils.Table where module Handler.Utils.Table where
-- General Utilities for Tables -- General Utilities for Tables
import Import hiding ((<>)) import Import
-- import Data.Monoid ((<>))
import Data.Profunctor import Data.Profunctor
import Control.Monad.Except import Control.Monad.Except
@ -59,11 +58,11 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
case () of case () of
_ | extId `elem` extIds _ | extId `elem` extIds
-> Just <$> (lift $ fromExternal extId) -> Just <$> lift (fromExternal extId)
| otherwise | otherwise
-> return Nothing -> return Nothing
view _ name attributes val _ = do view _ name attributes val _ =
[whamlet| [whamlet|
<label style="display: block"> <label style="display: block">
<input type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked> <input type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>

4
src/Handler/Utils/Table/Cells.hs
View File

@ -63,7 +63,7 @@ courseCellCL (tid,ssh,csh) = anchorCell link name
name = citext2widget csh name = citext2widget csh
courseCell :: IsDBTable m a => Course -> DBCell m a courseCell :: IsDBTable m a => Course -> DBCell m a
courseCell (Course {..}) = anchorCell link name `mappend` desc courseCell Course{..} = anchorCell link name `mappend` desc
where where
link = CourseR courseTerm courseSchool courseShorthand CShowR link = CourseR courseTerm courseSchool courseShorthand CShowR
name = citext2widget courseName name = citext2widget courseName
@ -90,7 +90,7 @@ submissionCell crse shn sid =
csh = crse ^. _3 csh = crse ^. _3
mkCid = encrypt sid mkCid = encrypt sid
mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR
mkText cid = display2widget cid mkText = display2widget
in anchorCellM' mkCid mkRoute mkText in anchorCellM' mkCid mkRoute mkText
correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a

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

@ -39,8 +39,8 @@ import qualified Network.Wai as Wai
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Control.Monad.RWS hiding ((<>), mapM_, forM_) import Control.Monad.RWS hiding ((<>), mapM_)
import Control.Monad.Writer hiding ((<>), mapM_, forM_) import Control.Monad.Writer hiding ((<>), mapM_)
import Control.Monad.Reader (ReaderT(..), mapReaderT) import Control.Monad.Reader (ReaderT(..), mapReaderT)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
@ -92,7 +92,7 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
filterColumn' cont is t = filterColumn' (cont t) is t filterColumn' cont is t = filterColumn' (cont t) is t
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
filterColumn' cont is t = filterColumn' (cont input) is' t filterColumn' cont is = filterColumn' (cont input) is'
where where
(input, ($ []) -> is') = go (mempty, id) is (input, ($ []) -> is') = go (mempty, id) is
go acc [] = acc go acc [] = acc
@ -261,12 +261,12 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
dbCell = iso dbCell = iso
(\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents)) (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
(\(attrs, mkWidget) -> WidgetCell attrs mkWidget) (uncurry WidgetCell)
-- dbWidget Proxy Proxy = iso (, ()) $ view _1 -- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget _ = return . snd dbWidget _ = return . snd
dbHandler _ f = return . over _2 f dbHandler _ f = return . over _2 f
runDBTable act = liftHandlerT act runDBTable = liftHandlerT
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
mempty = WidgetCell mempty $ return mempty mempty = WidgetCell mempty $ return mempty
@ -282,7 +282,7 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
dbCell = iso dbCell = iso
(\DBCell{..} -> (dbCellAttrs, dbCellContents)) (\DBCell{..} -> (dbCellAttrs, dbCellContents))
(\(attrs, mkWidget) -> DBCell attrs mkWidget) (uncurry DBCell)
dbWidget _ = return . snd dbWidget _ = return . snd
dbHandler _ f = return . over _2 f dbHandler _ f = return . over _2 f
@ -313,7 +313,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
dbWidget _ = liftHandlerT . fmap (view $ _1 . _2) . runFormPost dbWidget _ = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
dbHandler _ f form = return $ \csrf -> over _2 f <$> form csrf dbHandler _ f form = return $ fmap (over _2 f) . form
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype) -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget)) -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
@ -328,7 +328,7 @@ instance IsDBTable m a => IsString (DBCell m a) where
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x) dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. }) = do dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
let let
sortingOptions = mkOptionList sortingOptions = mkOptionList
[ Option t' (t, d) t' [ Option t' (t, d) t'
@ -350,7 +350,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
psResult <- runInputGetResult $ PaginationInput psResult <- runInputGetResult $ PaginationInput
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
<*> ((assertM' $ not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
<*> iopt intField (wIdent "pagesize") <*> iopt intField (wIdent "pagesize")
<*> iopt intField (wIdent "page") <*> iopt intField (wIdent "page")
<*> ireq checkBoxField (wIdent "table-only") <*> ireq checkBoxField (wIdent "table-only")
@ -459,7 +459,7 @@ cell :: IsDBTable m a => Widget -> DBCell m a
cell wgt = dbCell # ([], return wgt) cell wgt = dbCell # ([], return wgt)
textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
textCell = cell . toWidget . (pack :: [Char] -> Text) . otoList textCell = cell . toWidget . (pack :: String -> Text) . otoList
stringCell = textCell stringCell = textCell
i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
@ -491,10 +491,10 @@ anchorCell' :: IsDBTable m a
-> (r -> DBCell m a) -> (r -> DBCell m a)
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val) anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
anchorCellM :: IsDBTable m a => (WidgetT UniWorX IO (Route UniWorX)) -> Widget -> DBCell m a anchorCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> Widget -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget) anchorCellM routeM widget = anchorCellM' routeM id (const widget)
anchorCellM' :: IsDBTable m a => (WidgetT UniWorX IO x) -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a anchorCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
anchorCellM' xM x2route x2widget = cell $ do anchorCellM' xM x2route x2widget = cell $ do
x <- xM x <- xM
let route = x2route x let route = x2route x
@ -523,7 +523,7 @@ getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
formCell :: forall r i a. Ord i formCell :: forall r i a. Ord i
=> (r -> MForm (HandlerT UniWorX IO) i) => (r -> MForm (HandlerT UniWorX IO) i)
-> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
-> (r -> DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a))) -> (r -> DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a)))
formCell genIndex genForm input = FormCell formCell genIndex genForm input = FormCell
{ formCellAttrs = [] { formCellAttrs = []
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget) , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
@ -541,7 +541,7 @@ dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ db
dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i) dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
=> Setter' a Bool => Setter' a Bool
-> (r -> MForm (HandlerT UniWorX IO) i) -> (r -> MForm (HandlerT UniWorX IO) i)
-> Colonnade h r (DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a))) -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a)))
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
(selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False) (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|]) return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])

2
src/Handler/Utils/Zip.hs
View File

@ -81,7 +81,7 @@ produceZip info = mapC toZipData =$= void (zipStream zipOptions)
} }
toZipData :: Monad m => File -> (ZipEntry, ZipData m) toZipData :: Monad m => File -> (ZipEntry, ZipData m)
toZipData f@(File{..}) = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent) toZipData f@File{..} = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
toZipEntry :: File -> ZipEntry toZipEntry :: File -> ZipEntry
toZipEntry File{..} = ZipEntry toZipEntry File{..} = ZipEntry

2
src/Jobs/Crontab.hs
View File

@ -92,7 +92,7 @@ determineCrontab = execWriterT $ do
collateSubmissions :: [Entity Submission] -> Map UserId (Max (Maybe UTCTime)) collateSubmissions :: [Entity Submission] -> Map UserId (Max (Maybe UTCTime))
collateSubmissions = Map.fromListWith (<>) . fmap procCorrector collateSubmissions = Map.fromListWith (<>) . fmap procCorrector
where where
procCorrector :: Entity Submission -> (UserId , (Max (Maybe UTCTime))) procCorrector :: Entity Submission -> (UserId ,Max (Maybe UTCTime))
procCorrector = (,) <$> fromJust . submissionRatingBy . entityVal procCorrector = (,) <$> fromJust . submissionRatingBy . entityVal
<*> Max . submissionRatingAssigned . entityVal <*> Max . submissionRatingAssigned . entityVal

2
src/Jobs/Handler/SendNotification/SubmissionRated.hs
View File

@ -42,7 +42,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
, "submission-rating-comment" Aeson..= submissionRatingComment , "submission-rating-comment" Aeson..= submissionRatingComment
, "submission-rating-time" Aeson..= submissionRatingTime , "submission-rating-time" Aeson..= submissionRatingTime
, "submission-rating-by" Aeson..= (userDisplayName <$> corrector) , "submission-rating-by" Aeson..= (userDisplayName <$> corrector)
, "submission-rating-passed" Aeson..= (join $ gradingPassed <$> sheetType ^? _grading <*> submissionRatingPoints) , "submission-rating-passed" Aeson..= join (gradingPassed <$> sheetType ^? _grading <*> submissionRatingPoints)
, "sheet-name" Aeson..= sheetName , "sheet-name" Aeson..= sheetName
, "sheet-type" Aeson..= sheetType , "sheet-type" Aeson..= sheetType
, "course-name" Aeson..= courseName , "course-name" Aeson..= courseName

8
src/Model/Migration.hs
View File

@ -165,16 +165,16 @@ customMigrations = Map.fromListWith (>>)
|] |]
forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
Just name -> update uid [UserSurname =. name] Just name -> update uid [UserSurname =. name]
_other -> error $ "Empty userDisplayName found" _other -> error "Empty userDisplayName found"
) )
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|] , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
, whenM (tableExists "sheet") $ do , whenM (tableExists "sheet") $
[executeQQ| [executeQQ|
ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }'; ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|] |]
) )
, ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|] , ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
, whenM (columnExists "user" "plugin") $ do , whenM (columnExists "user" "plugin") $
-- <> is standard sql for /= -- <> is standard sql for /=
[executeQQ| [executeQQ|
DELETE FROM "user" WHERE "plugin" <> 'LDAP'; DELETE FROM "user" WHERE "plugin" <> 'LDAP';
@ -183,7 +183,7 @@ customMigrations = Map.fromListWith (>>)
|] |]
) )
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|] , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
, whenM (tableExists "user") $ do , whenM (tableExists "user") $
[executeQQ| [executeQQ|
ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" json NOT NULL DEFAULT '[]'; ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" json NOT NULL DEFAULT '[]';
|] |]

8
src/Model/Migration/Types.hs
View File

@ -1,6 +1,6 @@
module Model.Migration.Types where module Model.Migration.Types where
import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) import ClassyPrelude.Yesod
import Data.Aeson.TH (deriveJSON, defaultOptions) import Data.Aeson.TH (deriveJSON, defaultOptions)
import Database.Persist.Sql import Database.Persist.Sql
@ -15,9 +15,9 @@ data SheetType
deriving (Show, Read, Eq) deriving (Show, Read, Eq)
sheetType :: SheetType -> Current.SheetType sheetType :: SheetType -> Current.SheetType
sheetType Bonus {..} = Current.Bonus $ Current.Points {..} sheetType Bonus {..} = Current.Bonus Current.Points {..}
sheetType Normal {..} = Current.Normal $ Current.Points {..} sheetType Normal {..} = Current.Normal Current.Points {..}
sheetType Pass {..} = Current.Normal $ Current.PassPoints {..} sheetType Pass {..} = Current.Normal Current.PassPoints {..}
sheetType NotGraded = Current.NotGraded sheetType NotGraded = Current.NotGraded
{- TODO: {- TODO:

21
src/Model/Migration/Version.hs
View File

@ -64,22 +64,25 @@ instance PersistFieldSql Version where
version, migrationVersion :: QuasiQuoter version, migrationVersion :: QuasiQuoter
version = QuasiQuoter{..} version = undefinedQuote{quoteExp}
where where
quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of
[x] -> x [x] -> TH.lift x
[] -> error "No parse" [] -> error "No parse"
_ -> error "Ambiguous parse" _ -> error "Ambiguous parse"
quotePat = error "version cannot be used as pattern" migrationVersion = undefinedQuote{quoteExp}
quoteType = error "version cannot be used as type"
quoteDec = error "version cannot be used as declaration"
migrationVersion = QuasiQuoter{..}
where where
quoteExp "initial" = TH.lift InitialVersion quoteExp "initial" = TH.lift InitialVersion
quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of quoteExp v = case [ x | (x, "") <- readP_to_S parseVersion v] of
[x] -> MigrationVersion x [x] -> TH.lift $ MigrationVersion x
[] -> error "No parse" [] -> error "No parse"
_ -> error "Ambiguous parse" _ -> error "Ambiguous parse"
undefinedQuote :: QuasiQuoter
undefinedQuote = QuasiQuoter{..}
where
quoteExp = error "version cannot be used as expression"
quotePat = error "version cannot be used as pattern" quotePat = error "version cannot be used as pattern"
quoteType = error "version cannot be used as type" quoteType = error "version cannot be used as type"
quoteDec = error "version cannot be used as declaration" quoteDec = error "version cannot be used as declaration"

2
src/Settings/Cluster.hs
View File

@ -114,7 +114,7 @@ instance FromJSON ClientSession.Key where
instance ClusterSetting 'ClusterErrorMessageKey where instance ClusterSetting 'ClusterErrorMessageKey where
type ClusterSettingValue 'ClusterErrorMessageKey = SecretBox.Key type ClusterSettingValue 'ClusterErrorMessageKey = SecretBox.Key
initClusterSetting _ = liftIO $ SecretBox.newKey initClusterSetting _ = liftIO SecretBox.newKey
knownClusterSetting _ = ClusterErrorMessageKey knownClusterSetting _ = ClusterErrorMessageKey
instance ToJSON SecretBox.Key where instance ToJSON SecretBox.Key where

4
src/Utils/DB.hs
View File

@ -24,11 +24,11 @@ entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal ent
getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m (Maybe (Key record)) => Unique record -> ReaderT backend m (Maybe (Key record))
getKeyBy u = (fmap entityKey) <$> getBy u -- TODO optimize this, so that DB does not deliver entire record! getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m (Key record) => Unique record -> ReaderT backend m (Key record)
getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record! getKeyBy404 = fmap entityKey . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m Bool => Unique record -> ReaderT backend m Bool

96
src/Utils/Form.hs
View File

@ -31,7 +31,7 @@ data FormLayout = FormStandard
renderAForm :: Monad m => FormLayout -> FormRender m a renderAForm :: Monad m => FormLayout -> FormRender m a
renderAForm formLayout aform fragment = do renderAForm formLayout aform fragment = do
(res, (($ []) -> views)) <- aFormToForm aform (res, ($ []) -> views) <- aFormToForm aform
let widget = $(widgetFile "widgets/form") let widget = $(widgetFile "widgets/form")
return (res, widget) return (res, widget)
@ -40,58 +40,58 @@ renderAForm formLayout aform fragment = do
-------------------- --------------------
fsl :: Text -> FieldSettings site fsl :: Text -> FieldSettings site
fsl lbl = fsl lbl
FieldSettings { fsLabel = (SomeMessage lbl) = FieldSettings { fsLabel = SomeMessage lbl
, fsTooltip = Nothing , fsTooltip = Nothing
, fsId = Nothing , fsId = Nothing
, fsName = Nothing , fsName = Nothing
, fsAttrs = [] , fsAttrs = []
} }
fslI :: RenderMessage site msg => msg -> FieldSettings site fslI :: RenderMessage site msg => msg -> FieldSettings site
fslI lbl = fslI lbl
FieldSettings { fsLabel = (SomeMessage lbl) = FieldSettings { fsLabel = SomeMessage lbl
, fsTooltip = Nothing , fsTooltip = Nothing
, fsId = Nothing , fsId = Nothing
, fsName = Nothing , fsName = Nothing
, fsAttrs = [] , fsAttrs = []
} }
fslp :: Text -> Text -> FieldSettings site fslp :: Text -> Text -> FieldSettings site
fslp lbl placeholder = fslp lbl placeholder
FieldSettings { fsLabel = (SomeMessage lbl) = FieldSettings { fsLabel = SomeMessage lbl
, fsTooltip = Nothing , fsTooltip = Nothing
, fsId = Nothing , fsId = Nothing
, fsName = Nothing , fsName = Nothing
, fsAttrs = [("placeholder", placeholder)] , fsAttrs = [("placeholder", placeholder)]
} }
fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
fslpI lbl placeholder = fslpI lbl placeholder
FieldSettings { fsLabel = (SomeMessage lbl) = FieldSettings { fsLabel = SomeMessage lbl
, fsTooltip = Nothing , fsTooltip = Nothing
, fsId = Nothing , fsId = Nothing
, fsName = Nothing , fsName = Nothing
, fsAttrs = [("placeholder", placeholder)] , fsAttrs = [("placeholder", placeholder)]
} }
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) } addAttr attr valu fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
where where
newAttrs :: [(Text,Text)] -> [(Text,Text)] newAttrs :: [(Text,Text)] -> [(Text,Text)]
newAttrs [] = [(attr,valu)] newAttrs [] = [(attr, valu)]
newAttrs (p@(a,v):t) newAttrs (p@(a,v) : t)
| attr==a = (a,T.append valu $ cons ' ' v):t | attr==a = (a, T.append valu $ cons ' ' v) : t
| otherwise = p:(newAttrs t) | otherwise = p : newAttrs t
addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) } addAttrs attr valus fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
where where
newAttrs :: [(Text,Text)] -> [(Text,Text)] newAttrs :: [(Text, Text)] -> [(Text, Text)]
newAttrs [] = [(attr,T.intercalate " " valus)] newAttrs [] = [(attr, T.intercalate " " valus)]
newAttrs (p@(a,v):t) newAttrs (p@(a,v) : t)
| attr==a = (a,T.intercalate " " (v:valus)):t | attr==a = ( a, T.intercalate " " $ v : valus ) : t
| otherwise = p:(newAttrs t) | otherwise = p : newAttrs t
addClass :: Text -> FieldSettings site -> FieldSettings site addClass :: Text -> FieldSettings site -> FieldSettings site
addClass = addAttr "class" addClass = addAttr "class"
@ -103,17 +103,19 @@ addName :: Text -> FieldSettings site -> FieldSettings site
addName nm fs = fs { fsName = Just nm } addName nm fs = fs { fsName = Just nm }
addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) } addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }
addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) } addIdClass gId gClass fs = fs { fsId = Just gId, fsAttrs = ("class",gClass) : fsAttrs fs }
setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) } setClass fs c = fs { fsAttrs = ("class",c) : fsAttrs fs }
setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) } setNameClass fs gName gClass = fs { fsName = Just gName
, fsAttrs = ("class",gClass) : fsAttrs fs
}
setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg } setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
@ -179,7 +181,7 @@ identForm = identifyForm . toPathPiece
data family ButtonCssClass site :: * data family ButtonCssClass site :: *
bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc)) bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> drop 2 (show bcc))
class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
label :: a -> WidgetT site IO () label :: a -> WidgetT site IO ()
@ -213,7 +215,7 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
fieldParse _ _ = return $ Left "Multiple button values" fieldParse _ _ = return $ Left "Multiple button values"
combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a] combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
combinedButtonField btns = traverse b2f btns combinedButtonField = traverse b2f
where where
b2f b = aopt (buttonField b) "" Nothing b2f b = aopt (buttonField b) "" Nothing
@ -247,7 +249,7 @@ reorderField optList = Field{..}
olNum = fromIntegral $ length olOptions olNum = fromIntegral $ length olOptions
selOptions = Map.fromList $ do selOptions = Map.fromList $ do
i <- [1..olNum] i <- [1..olNum]
(readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist (readMay -> Just (n :: Word), '.' : extVal) <- break (== '.') . unpack <$> optlist
guard $ i == n guard $ i == n
Just val <- return . olReadExternal $ pack extVal Just val <- return . olReadExternal $ pack extVal
return (i, val) return (i, val)

4
src/Utils/Lang.hs
View File

@ -24,9 +24,7 @@ selectLanguage' avL (l:ls)
| not $ null l | not $ null l
, Just lParts <- NonEmpty.nonEmpty $ Text.splitOn "-" l , Just lParts <- NonEmpty.nonEmpty $ Text.splitOn "-" l
, found <- find ((NonEmpty.toList lParts `isPrefixOf`) . Text.splitOn "-") avL , found <- find ((NonEmpty.toList lParts `isPrefixOf`) . Text.splitOn "-") avL
= case found of = flip fromMaybe found $ selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
Just l' -> l'
Nothing -> selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
| otherwise = selectLanguage' avL ls | otherwise = selectLanguage' avL ls
langMatches :: Lang -- ^ Needle langMatches :: Lang -- ^ Needle