diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 000000000..d2a622292 --- /dev/null +++ b/.hlint.yaml @@ -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 diff --git a/hlint/Hlint.hs b/hlint/Hlint.hs index 4990226af..857467823 100644 --- a/hlint/Hlint.hs +++ b/hlint/Hlint.hs @@ -1 +1,4 @@ -{-# OPTIONS_GHC -F -pgmF hlint-test -optF --git -optF -j -optF src #-} +{-# OPTIONS_GHC + -F -pgmF hlint-test + -optF src + #-} diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 647d1e273..8b1028f48 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -72,7 +72,7 @@ postMessageR cID = do 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 runDB $ delete tId addMessageI Success MsgSystemMessageDeleteTranslationSuccess @@ -111,7 +111,7 @@ postMessageR cID = do maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True forms <- traverse (const mkForm) $ () <$ guard maySubmit - defaultLayout $ do + defaultLayout $ $(widgetFile "system-message") where modifySystemMessage smId SystemMessage{..} = do @@ -162,7 +162,7 @@ postMessageListR = do dbtColonnade = mconcat [ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId , 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 "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly @@ -175,12 +175,12 @@ postMessageListR = do ] dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do Just (_, smT) <- lift $ getSystemMessage appLanguages smId - return $ DBRow + return DBRow { dbrOutput = (smE, smT) , .. } psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool)) - tableForm <- dbTable psValidator $ DBTable + tableForm <- dbTable psValidator DBTable { dbtSQLQuery , dbtColonnade , dbtProj @@ -194,8 +194,8 @@ postMessageListR = do , dbtIdent = "messages" :: Text } ((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do - ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf - now <- liftIO $ getCurrentTime + (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf + now <- liftIO getCurrentTime let actions = Map.fromList [ (SMDelete, pure SMDDelete) , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now)) @@ -248,5 +248,5 @@ postMessageListR = do addMessageI Success $ MsgSystemMessageAdded cID redirect $ MessageR cID - defaultLayout $ do + defaultLayout $ $(widgetFile "system-message-list") diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 8507168e7..e5bb7641e 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -13,7 +13,7 @@ import qualified Database.Esqueleto as E validateTerm :: Term -> [Text] -validateTerm (Term{..}) = +validateTerm Term{..} = [ msg | (False, msg) <- [ --startOk ( termStart `withinTerm` termName @@ -68,7 +68,7 @@ getTermShowR = do , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> cell $ formatTime SelFormatDate termLectureEnd >>= toWidget , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) -> - textCell $ (bool "" tickmark termActive :: Text) + textCell (bool "" tickmark termActive :: Text) , sortable Nothing "Kurse" $ \(_, E.Value numCourses) -> cell [whamlet|_{MsgNumCourses numCourses}|] , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> @@ -96,7 +96,7 @@ getTermShowR = do -- #{termToText termName} -- |] -- ] - ((), table) <- dbTable def $ DBTable + ((), table) <- dbTable def DBTable { dbtSQLQuery = termData , dbtColonnade = colonnadeTerms , dbtProj = return . dbrOutput @@ -116,12 +116,12 @@ getTermShowR = do ] , dbtFilter = Map.fromList [ ( "active" - , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool)) + , FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool) ) , ( "course" , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are [] -> 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.&&. course E.^. CourseShorthand `E.in_` E.valList cshs ) @@ -134,7 +134,7 @@ getTermShowR = do $(widgetFile "terms") getTermEditR :: Handler Html -getTermEditR = do +getTermEditR = -- TODO: Defaults für Semester hier ermitteln und übergeben termEditHandler Nothing @@ -162,7 +162,7 @@ termEditHandler term = do -- MIT INTERNATIONALISIERUNG: addMessageI Success $ MsgTermEdited tid redirect TermShowR - (FormMissing ) -> return () + FormMissing -> return () (FormFailure _) -> addMessageI Warning MsgInvalidInput let actionUrl = TermEditR defaultLayout $ do diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 0b6fb1c87..178957385 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -69,7 +69,7 @@ getUsersR = do psValidator = def & 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)) , dbtColonnade , dbtProj = return @@ -106,7 +106,7 @@ postAdminHijackUserR cID = do otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] 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" get404 uid diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index da07f0477..67beeabd1 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -31,7 +31,7 @@ downloadFiles = do return userDefaultDownloadFiles tidFromText :: Text -> Maybe TermId -tidFromText = (fmap TermKey) . maybeRight . termFromText +tidFromText = fmap TermKey . maybeRight . termFromText simpleLink :: Widget -> Route UniWorX -> Widget simpleLink lbl url = [whamlet|^{lbl}|] diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index f5db92758..890990027 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -10,7 +10,7 @@ module Handler.Utils.DateTime import Import -import Data.Time.Zones hiding (localTimeToUTCFull) +import Data.Time.Zones import qualified Data.Time.Zones as TZ import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime) @@ -36,7 +36,7 @@ instance HasLocalTime Day where toLocalTime d = LocalTime d midnight instance HasLocalTime UTCTime where - toLocalTime t = utcToLocalTime t + toLocalTime = utcToLocalTime 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) @@ -78,7 +78,7 @@ getDateTimeFormat sel = do 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 -validDateTimeFormats _ SelFormatDateTime = Set.fromList $ +validDateTimeFormats _ SelFormatDateTime = Set.fromList [ DateTimeFormat "%a %d %b %Y %R" , DateTimeFormat "%a %b %d %Y %R" , DateTimeFormat "%A, %d %B %Y %R" @@ -95,7 +95,7 @@ validDateTimeFormats _ SelFormatDateTime = Set.fromList $ , DateTimeFormat "%Y-%m-%d %T" , DateTimeFormat "%Y-%m-%dT%T" ] -validDateTimeFormats _ SelFormatDate = Set.fromList $ +validDateTimeFormats _ SelFormatDate = Set.fromList [ DateTimeFormat "%a %d %b %Y" , DateTimeFormat "%a %b %d %Y" , DateTimeFormat "%A, %d %B %Y" @@ -126,7 +126,7 @@ dateTimeFormatOptions sel = do let toOption fmt@DateTimeFormat{..} = do dateTime <- formatTime' unDateTimeFormat now - return $ (dateTime, fmt) + return (dateTime, fmt) optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index bdf9490d9..8f71ec0a9 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -131,7 +131,7 @@ buttonForm csrf = do buttonIdent <- newFormIdent let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing (results, btnViews) <- unzip <$> mapM button [minBound..maxBound] - let widget = do + let widget = [whamlet| #{csrf} $forall bView <- btnViews @@ -163,16 +163,16 @@ natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMess natFieldI msg = checkBool (>= 0) msg intField 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 = natField 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 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 = checkBool (>= 0) MsgPointsNotPositive Field{..} @@ -252,7 +252,7 @@ zipFileField doUnpack = Field{..} | [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f | null files = return $ Right Nothing | otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile - fieldView fieldId fieldName attrs _ req = do + fieldView fieldId fieldName attrs _ req = [whamlet| $newline never @@ -450,7 +450,7 @@ utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing) -- Browser returns LocalTime utcTimeField = Field - { fieldParse = parseHelperGen $ readTime + { fieldParse = parseHelperGen readTime , fieldView = \theId name attrs val isReq -> do val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val [whamlet| @@ -468,10 +468,10 @@ utcTimeField = Field readTime :: Text -> Either UniWorXMessage UTCTime readTime t = case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of - (Just (LTUUnique time _)) -> Right time - (Just (LTUNone _ _)) -> Left MsgIllDefinedUTCTime - (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime - Nothing -> Left MsgInvalidDateTimeFormat + Just LTUUnique{_ltuResult} -> Right _ltuResult + Just LTUNone{} -> Left MsgIllDefinedUTCTime + Just LTUAmbiguous{} -> Left MsgAmbiguousUTCTime + Nothing -> Left MsgInvalidDateTimeFormat langField :: Bool -- ^ Only allow values from `appLanguages` -> Field (HandlerT UniWorX IO) Lang @@ -547,13 +547,13 @@ apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) -- ^ Pseudo required apreq f fs mx = formToAForm $ do 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) => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a) wpreq f fs mx = mFormToWForm $ do 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) => Map action (AForm (HandlerT UniWorX IO) a) diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index dc8bbc8dd..269fd927a 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -13,7 +13,7 @@ module Handler.Utils.Rating , extractRatings ) where -import Import hiding (()) +import Import import Text.PrettyPrint.Leijen.Text hiding ((<$>)) @@ -56,9 +56,9 @@ instance Pretty x => Pretty (CI x) where instance Pretty SheetGrading where - pretty (Points {..}) = pretty ( (show maxPoints) <> " Punkte" :: String) - pretty (PassPoints {..}) = pretty ( (show maxPoints) <> " Punkte, bestanden ab " <> (show passingPoints) <> " Punkte" :: String ) - pretty (PassBinary) = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String ) + pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String) + pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String ) + pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String ) data Rating = Rating @@ -138,10 +138,10 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc 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 let - fileTitle = "bewertung_" <> (Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)) <.> "txt" + fileTitle = "bewertung_" <> Text.unpack (toPathPiece cID) <.> "txt" fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating return File{..} diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 75a82053b..9dbce258a 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -37,8 +37,8 @@ pKey :: Parser Int pKey = decimal pType :: Parser StudyFieldType -pType = FieldPrimary <$ (try $ string "HF") - <|> FieldSecondary <$ (try $ string "NF") +pType = FieldPrimary <$ try (string "HF") + <|> FieldSecondary <$ try (string "NF") decimal :: Parser Int decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit' diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index d784d1cdc..811da9e2f 100644 --- a/src/Handler/Utils/Table.hs +++ b/src/Handler/Utils/Table.hs @@ -1,8 +1,7 @@ module Handler.Utils.Table where -- General Utilities for Tables -import Import hiding ((<>)) --- import Data.Monoid ((<>)) +import Import import Data.Profunctor 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 case () of _ | extId `elem` extIds - -> Just <$> (lift $ fromExternal extId) + -> Just <$> lift (fromExternal extId) | otherwise -> return Nothing - view _ name attributes val _ = do + view _ name attributes val _ = [whamlet|