From 2dd5502af615cd100a19dfa83853be1d26b52180 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 16 Jan 2019 16:53:02 +0100 Subject: [PATCH 1/8] More robust handling of missing rows in forms within dbtable --- messages/uniworx/de.msg | 4 +- src/CryptoID/TH.hs | 6 -- src/Data/CaseInsensitive/Instances.hs | 19 +++++ src/Database/Esqueleto/Instances.hs | 25 ++++++ src/Database/Persist/Sql/Instances.hs | 33 ++++++++ src/Handler/Corrections.hs | 20 +++-- src/Handler/SystemMessage.hs | 2 +- src/Handler/Utils/Form.hs | 4 + src/Handler/Utils/Table/Pagination.hs | 86 ++++++++++++++------- src/Handler/Utils/Table/Pagination/Types.hs | 9 +++ src/Import/NoFoundation.hs | 5 ++ src/Model.hs | 6 ++ src/Model/Types.hs | 28 ++----- 13 files changed, 178 insertions(+), 69 deletions(-) create mode 100644 src/Database/Esqueleto/Instances.hs create mode 100644 src/Database/Persist/Sql/Instances.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5521a602e..23e775b55 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -598,4 +598,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. \ No newline at end of file +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 \ No newline at end of file diff --git a/src/CryptoID/TH.hs b/src/CryptoID/TH.hs index 589c30637..c3f1e4322 100644 --- a/src/CryptoID/TH.hs +++ b/src/CryptoID/TH.hs @@ -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 diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index bfc2790ff..3986e3cc7 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -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 + diff --git a/src/Database/Esqueleto/Instances.hs b/src/Database/Esqueleto/Instances.hs new file mode 100644 index 000000000..c4dabfe41 --- /dev/null +++ b/src/Database/Esqueleto/Instances.hs @@ -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 diff --git a/src/Database/Persist/Sql/Instances.hs b/src/Database/Persist/Sql/Instances.hs new file mode 100644 index 000000000..2d0044164 --- /dev/null +++ b/src/Database/Persist/Sql/Instances.hs @@ -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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 794d88071..9e26078c6 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -49,8 +49,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 @@ -126,7 +124,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) @@ -172,23 +170,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 ) @@ -822,7 +820,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 diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 2f23745e2..a2b661363 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -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) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index f5e88ba29..793cb9077 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 15716149a..dcfcf36aa 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -75,6 +75,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]) @@ -245,10 +253,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 +269,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) } @@ -345,7 +355,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 +386,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 +479,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 @@ -638,13 +657,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 +702,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 +820,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 {- ^ Make input name suitably unique -}) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) + -> (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 +859,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}|]) diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index f83c27e4d..fb53015fd 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -8,6 +8,7 @@ module Handler.Utils.Table.Pagination.Types , SortableP(..) , SqlIn(..) , sqlInTuples + , DBTableInvalid(..) ) where import Import hiding (singleton) @@ -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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 3240920b8..308b5a6dd 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -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) diff --git a/src/Model.hs b/src/Model.hs index 9eb258cc3..54acc1b28 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index accb05fe0..abb5fd27a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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{..} From f67e19f933c41e92edf72b4af4dae20833c5e701 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 16 Jan 2019 16:54:33 +0100 Subject: [PATCH 2/8] Bump ChangeLog.md --- ChangeLog.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index a4bf845fb..784dc8824 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 From 966c60acb17938d269cc69c81a8ffaaac5fc32a6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 16 Jan 2019 18:01:25 +0100 Subject: [PATCH 3/8] Always reproduce sorting of previousKeys --- src/Handler/Utils/Table/Pagination.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index dcfcf36aa..7c25163fe 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -67,6 +67,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) @@ -642,8 +644,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db = succ (psPage * l) | otherwise = 1 + reproduceSorting rows + | Just ps <- previousKeys = sortOn (\(_, dbrKey, _) -> elemIndex dbrKey ps) rows + | otherwise = rows - (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 From 7f103ec7a93425e8ea523b76284417e7f7643100 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 16 Jan 2019 23:47:21 +0100 Subject: [PATCH 4/8] Additional tests & cleanup --- models/courses | 1 + models/schools | 2 +- models/sheets | 1 + models/submissions | 2 +- models/terms | 2 +- models/users | 2 +- package.yaml | 3 + src/Handler/Utils/Table/Pagination.hs | 29 ++-- src/Handler/Utils/Table/Pagination/Types.hs | 4 +- test/Handler/CorrectionsSpec.hs | 11 ++ .../Utils/Table/Pagination/TypesSpec.hs | 22 +++ test/Handler/Utils/Table/PaginationSpec.hs | 43 ++++++ test/Handler/Utils/ZipSpec.hs | 23 +-- test/MailSpec.hs | 19 +-- test/Model/TypesSpec.hs | 131 ++++++++++-------- test/ModelSpec.hs | 107 ++++++++++++++ test/TestImport.hs | 2 +- test/Utils/DateTimeSpec.hs | 9 +- 18 files changed, 301 insertions(+), 112 deletions(-) create mode 100644 test/Handler/CorrectionsSpec.hs create mode 100644 test/Handler/Utils/Table/Pagination/TypesSpec.hs create mode 100644 test/Handler/Utils/Table/PaginationSpec.hs create mode 100644 test/ModelSpec.hs diff --git a/models/courses b/models/courses index 80b2ac5ac..96bba0195 100644 --- a/models/courses +++ b/models/courses @@ -19,6 +19,7 @@ Course materialFree Bool TermSchoolCourseShort term school shorthand TermSchoolCourseName term school name + deriving Generic CourseEdit user UserId time UTCTime diff --git a/models/schools b/models/schools index b253c7390..625235f2f 100644 --- a/models/schools +++ b/models/schools @@ -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 diff --git a/models/sheets b/models/sheets index 207f22ee0..8fd75eae1 100644 --- a/models/sheets +++ b/models/sheets @@ -14,6 +14,7 @@ Sheet submissionMode SheetSubmissionMode default='UserSubmissions' autoDistribute Bool default=false CourseSheet course name + deriving Generic SheetEdit user UserId time UTCTime diff --git a/models/submissions b/models/submissions index db7e543a6..ff998b845 100644 --- a/models/submissions +++ b/models/submissions @@ -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 diff --git a/models/terms b/models/terms index ba6cafd73..698a6a6d1 100644 --- a/models/terms +++ b/models/terms @@ -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 diff --git a/models/users b/models/users index 0cd2d682a..5ac4a6a3c 100644 --- a/models/users +++ b/models/users @@ -15,7 +15,7 @@ User json notificationSettings NotificationSettings UniqueAuthentication ident UniqueEmail email - deriving Show Eq + deriving Show Eq Generic UserAdmin user UserId school SchoolId diff --git a/package.yaml b/package.yaml index 1bd402afd..fcfce4831 100644 --- a/package.yaml +++ b/package.yaml @@ -231,6 +231,9 @@ tests: - http-types ghc-options: - -fno-warn-orphans + - -threaded + - -rtsopts + - -with-rtsopts=-N hlint: main: Hlint.hs other-modules: [] diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 7c25163fe..c48f8b2d9 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 @@ -92,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 @@ -114,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 @@ -606,19 +608,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 @@ -644,9 +641,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db = succ (psPage * l) | otherwise = 1 - reproduceSorting rows - | Just ps <- previousKeys = sortOn (\(_, dbrKey, _) -> elemIndex dbrKey ps) rows - | otherwise = rows + 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..] $ reproduceSorting rows' diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index fb53015fd..44648cf21 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -29,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) diff --git a/test/Handler/CorrectionsSpec.hs b/test/Handler/CorrectionsSpec.hs new file mode 100644 index 000000000..a26d1c1bd --- /dev/null +++ b/test/Handler/CorrectionsSpec.hs @@ -0,0 +1,11 @@ +module Handler.CorrectionsSpec where + +import TestImport + +import ModelSpec () + + +spec :: Spec +spec = withApp $ do + describe "CorrectionsR" $ do + return () diff --git a/test/Handler/Utils/Table/Pagination/TypesSpec.hs b/test/Handler/Utils/Table/Pagination/TypesSpec.hs new file mode 100644 index 000000000..f1f29506a --- /dev/null +++ b/test/Handler/Utils/Table/Pagination/TypesSpec.hs @@ -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 ] diff --git a/test/Handler/Utils/Table/PaginationSpec.hs b/test/Handler/Utils/Table/PaginationSpec.hs new file mode 100644 index 000000000..df8a7fd91 --- /dev/null +++ b/test/Handler/Utils/Table/PaginationSpec.hs @@ -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 == "{}") diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs index 19e176840..eaa471881 100644 --- a/test/Handler/Utils/ZipSpec.hs +++ b/test/Handler/Utils/ZipSpec.hs @@ -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 diff --git a/test/MailSpec.hs b/test/MailSpec.hs index 6743f99fa..c9972548d 100644 --- a/test/MailSpec.hs +++ b/test/MailSpec.hs @@ -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 ] diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index bd192c991..bfe154a02 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -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 $ diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs new file mode 100644 index 000000000..33a54c2e3 --- /dev/null +++ b/test/ModelSpec.hs @@ -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 ] diff --git a/test/TestImport.hs b/test/TestImport.hs index 344021b64..9d84e8722 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -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 diff --git a/test/Utils/DateTimeSpec.hs b/test/Utils/DateTimeSpec.hs index e851c95e9..b2480749d 100644 --- a/test/Utils/DateTimeSpec.hs +++ b/test/Utils/DateTimeSpec.hs @@ -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 ] From 4e718ee28760f37f607a2ddddd69a8bc9ede3c65 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 17 Jan 2019 11:44:18 +0100 Subject: [PATCH 5/8] Cleanup & haddock --- haddock.sh | 3 +++ src/Application.hs | 2 +- src/Handler/Home.hs | 4 ++-- src/Handler/Sheet.hs | 2 +- src/Handler/Submission.hs | 2 +- src/Handler/Utils/Submission.hs | 6 +++--- src/Handler/Utils/Table/Pagination.hs | 9 +++++---- src/Jobs.hs | 2 +- src/Mail.hs | 2 +- 9 files changed, 18 insertions(+), 14 deletions(-) create mode 100755 haddock.sh diff --git a/haddock.sh b/haddock.sh new file mode 100755 index 000000000..b7336921d --- /dev/null +++ b/haddock.sh @@ -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 --haddock-arguments "--optghc -cpp" diff --git a/src/Application.hs b/src/Application.hs index 144945e00..e92163430 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 390c349e9..6e7966103 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 86dbc9a03..3fb979a6a 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 9626ba382..d3d624d86 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 98bbd12ac..a397041a8 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -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 ] [] diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c48f8b2d9..3ef8450e0 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -330,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 @@ -839,7 +840,7 @@ 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 i a (DBRow r)) -> (DBRow r -> MForm (HandlerT UniWorX IO) i) - -> (DBRow r -> (forall p. PathPiece p => p -> Text {- ^ Make input name suitably unique -}) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) + -> (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 = [] diff --git a/src/Jobs.hs b/src/Jobs.hs index f214f2c3c..2a9a42556 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -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 diff --git a/src/Mail.hs b/src/Mail.hs index e05f8fa1c..c125bf88d 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -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 } From b938981d0e4f90074c16bacfad54a028767486c2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 22 Jan 2019 16:14:07 +0100 Subject: [PATCH 6/8] Fix haddock for testworx --- haddock.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock.sh b/haddock.sh index b7336921d..aaceeb329 100755 --- a/haddock.sh +++ b/haddock.sh @@ -1,3 +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 --haddock-arguments "--optghc -cpp" +exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal From 0a69047acf2851b84daf0b9d3539d54c6dbe5c1a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 22 Jan 2019 20:05:19 +0100 Subject: [PATCH 7/8] Introduce timeouts for all ldap actions --- config/settings.yml | 3 ++- package.yaml | 1 + src/Application.hs | 2 +- src/Auth/LDAP.hs | 8 +++--- src/Ldap/Client/Pool.hs | 57 ++++++++++++++++++++++++++--------------- src/Settings.hs | 4 ++- 6 files changed, 47 insertions(+), 28 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index e681e8e27..7c561ddfb 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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" diff --git a/package.yaml b/package.yaml index fcfce4831..46af6eab8 100644 --- a/package.yaml +++ b/package.yaml @@ -113,6 +113,7 @@ dependencies: - pkcs7 - memcached-binary - directory-tree + - lifted-base other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Application.hs b/src/Application.hs index e92163430..1dd037aba 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 0eebdd5f3..ee658b195 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -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 [] diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index ad84150e2..875078b6f 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -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 diff --git a/src/Settings.hs b/src/Settings.hs index b6d7c3397..f3ad5f7ac 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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{..} From 795dd29aa3510b2c755c6b5b11b085c84d496683 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 23 Jan 2019 13:15:03 +0100 Subject: [PATCH 8/8] Refine MenuSheetCurrent --- messages/uniworx/de.msg | 2 +- src/Foundation.hs | 13 +++++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7b8ee21b6..76f338b6e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -565,7 +565,7 @@ MenuCorrections: Korrekturen MenuSubmissions: Abgaben MenuSheetList: Übungsblätter MenuSheetNew: Neues Übungsblatt anlegen -MenuSheetCurrent: Akutelles Übungsblatt +MenuSheetCurrent: Aktuelles Übungsblatt MenuSheetLastInactive: Zuletzt abgegebenes Übungsblatt MenuCourseEdit: Kurs editieren MenuCourseNewTemplate: Als neuen Kurs klonen diff --git a/src/Foundation.hs b/src/Foundation.hs index 09a0869ff..535241b0c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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