More robust handling of missing rows in forms within dbtable

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

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
 

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
+

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

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

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

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)

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

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
+type DBTableKey k' = (ToJSON k', FromJSON k', Ord k', Binary k')
-  { dbrOutput :: r
+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)
+         => Lens' res (DBFormResult i a (DBRow r))
-         -> (r -> MForm (HandlerT UniWorX IO) i)
+         -> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-         -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
+         -> (DBRow r -> (forall p. PathPiece p => p -> Text {- ^ Make input name suitably unique -}) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
-         -> (r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
+         -> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
-formCell resLens genIndex genForm input = FormCell
+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)
+         -> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-         -> Colonnade h r (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
+         -> Colonnade h (DBRow 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
+dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
-  (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
+  where
-  return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])
+    genForm _ mkUnique = do
+      (selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
+      return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])

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

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)
 

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

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