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{..}