More robust handling of missing rows in forms within dbtable

2019-01-16 16:53:02 +01:00 · 2019-01-16 16:53:02 +01:00 · 2dd5502af6
commit 2dd5502af6
parent 5a898c3303
13 changed files with 178 additions and 69 deletions
--- 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.
+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
--- 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

--- 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
+
--- a/src/Database/Esqueleto/Instances.hs
+++ 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
--- a/src/Database/Persist/Sql/Instances.hs
+++ 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
--- 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
--- 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)
--- 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
--- 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}|])
--- 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
--- 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)

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