Make dbtable-forms more robust against pagination & dataset changes

messages/uniworx/de.msg

@@ -236,6 +236,7 @@ CorrSetCorrector: Korrektor zuweisen
 CorrAutoSetCorrector: Korrekturen verteilen
 NatField name@Text: #{name} muss eine natürliche Zahl sein!
 JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure}
+SecretJSONFieldDecryptFailure: Konnte versteckte vertrauliche Daten nicht entschlüsseln
 
 SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
 SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):

src/Handler/Corrections.hs

@@ -219,6 +219,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = d
         dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
   dbTable psValidator DBTable
     { dbtSQLQuery
+    , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
     , dbtColonnade
     , dbtProj
     , dbtSorting   = Map.fromList

src/Handler/Course.hs

@@ -126,6 +126,7 @@ makeCourseTable whereClause colChoices psValidator = do
       dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
   snd <$> dbTable psValidator DBTable
     { dbtSQLQuery
+    , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
     , dbtColonnade = colChoices
     , dbtProj
     , dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here

src/Handler/Home.hs

@@ -75,6 +75,7 @@ homeAnonymous = do
         ]
   courseTable <- runDB $ dbTableWidget' def DBTable
     { dbtSQLQuery  = tableData
+    , dbtRowKey    = (E.^. CourseId)
     , dbtColonnade = colonnade
     , dbtProj      = return
     , dbtSorting   = Map.fromList
@@ -171,6 +172,7 @@ homeUser uid = do
   let validator = def & defaultSorting [SortDescBy "done", SortDescBy "deadline"]
   sheetTable <- runDB $ dbTableWidget' validator DBTable
     { dbtSQLQuery  = tableData
+    , dbtRowKey    = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
     , dbtColonnade = colonnade
     , dbtProj      = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
                         -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)

src/Handler/Profile.hs

@@ -247,6 +247,7 @@ mkOwnedCoursesTable =
                  , course E.^. CourseSchool
                  , course E.^. CourseShorthand
                  )
+      dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId
       dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))
 
       dbtColonnade = mconcat
@@ -295,6 +296,7 @@ mkEnrolledCoursesTable =
           E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
           E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
           return (course, participant E.^. CourseParticipantRegistration)
+      , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
       , dbtProj      = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
       , dbtColonnade = mconcat
           [ dbRow
@@ -349,6 +351,7 @@ mkSubmissionTable =
                    )
         let sht  = sheet E.^. SheetName
         return (crse, sht, submission, lastSubEdit uid submission)
+      dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
 
       lastSubEdit uid submission = -- latest Edit-Time of this user for submission
         E.sub_select . E.from $ \subEdit -> do
@@ -429,6 +432,7 @@ mkSubmissionGroupTable =
                     , course E.^. CourseShorthand
                     )
         return (crse, sgroup, lastSGEdit sgroup)
+      dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
 
       lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
         E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
@@ -508,6 +512,7 @@ mkCorrectionsTable =
                     , course E.^. CourseShorthand
                     )
         return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
+      dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId
 
       dbtProj x = return $ x
         & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))

src/Handler/Sheet.hs

@@ -208,6 +208,7 @@ getSheetListR tid ssh csh = do
       { dbtColonnade = sheetCol
       , dbtSQLQuery  = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser))
                           -> sheetData dt *> return (sheet, lastSheetEdit sheet, submission)
+      , dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
       , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
                     -> dbr <$ guardM (lift $ sheetFilter sheetName)
       , dbtSorting   = Map.fromList
@@ -302,6 +303,7 @@ getSShowR tid ssh csh shn = do
         & defaultSorting [SortAscBy "type", SortAscBy "path"]
   (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery = fileData
+    , dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId
     , dbtColonnade = colonnadeFiles
     , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
                    -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)

src/Handler/Submission.hs

@@ -298,6 +298,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
         return ((sf1, f1), (sf2, f2))
       smid2ArchiveTable (smid,cid) = DBTable
         { dbtSQLQuery = submissionFiles smid
+        , dbtRowKey = \((_ `E.InnerJoin` f1) `E.FullOuterJoin` (_ `E.InnerJoin` f2)) -> (f1 E.?. FileId, f2 E.?. FileId)
         , dbtColonnade = colonnadeFiles cid
         , dbtProj = return . dbrOutput
         , dbtStyle = def

src/Handler/SystemMessage.hs

@@ -178,6 +178,7 @@ postMessageListR = do
     psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
   (tableRes', tableView) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery
+    , dbtRowKey = (E.^. SystemMessageId)
     , dbtColonnade
     , dbtProj
     , dbtSorting = Map.fromList

src/Handler/Term.hs

@@ -98,6 +98,7 @@ getTermShowR = do
 --           ]
       table <- runDB $ dbTableWidget' def DBTable
         { dbtSQLQuery = termData
+        , dbtRowKey = (E.^. TermId)
         , dbtColonnade = colonnadeTerms
         , dbtProj = return . dbrOutput
         , dbtSorting = Map.fromList

src/Handler/Users.hs

@@ -71,6 +71,7 @@ getUsersR = do
   
   ((), userList) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
+    , dbtRowKey = (E.^. UserId)
     , dbtColonnade
     , dbtProj      = return
     , dbtSorting   = Map.fromList

src/Handler/Utils/Form.hs

@@ -37,6 +37,7 @@ import Data.Map (Map, (!))
 import qualified Data.Map as Map
 
 import Control.Monad.Trans.Writer (execWriterT, WriterT)
+import Control.Monad.Except (runExceptT)
 import Control.Monad.Writer.Class
 
 import Data.Scientific (Scientific)
@@ -471,7 +472,7 @@ jsonField hide = Field{..}
     inputType
       | hide      = "hidden"
       | otherwise = "text"
-    fieldParse [v] [] = return . second Just . first (SomeMessage . MsgJSONFieldDecodeFailure) . eitherDecodeStrict' $ encodeUtf8 v
+    fieldParse [v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just . eitherDecodeStrict' $ encodeUtf8 v
     fieldParse [] [] = return $ Right Nothing
     fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
     fieldView theId name attrs val isReq = liftWidgetT [whamlet|
@@ -479,6 +480,23 @@ jsonField hide = Field{..}
     |]
     fieldEnctype = UrlEncoded
 
+secretJsonField :: ( ToJSON a, FromJSON a
+                   , MonadHandler m
+                   , HandlerSite m ~ UniWorX
+                   )
+                => Field m a
+secretJsonField = Field{..}
+  where
+    fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
+    fieldParse [] [] = return $ Right Nothing
+    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
+    fieldView theId name attrs val _isReq = do
+      val' <- traverse (encodedSecretBox SecretBoxShort) val
+      [whamlet|
+        <input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
+      |]
+    fieldEnctype = UrlEncoded
+    
 
 funcForm :: forall k v m.
             ( Finite k, Ord k

src/Handler/Utils/Table/Pagination.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS -fno-warn-orphans #-}
+
 module Handler.Utils.Table.Pagination
   ( module Handler.Utils.Table.Pagination.Types
   , SortColumn(..), SortDirection(..)
@@ -67,6 +69,11 @@ import Data.Aeson.TH (deriveJSON)
 
 import qualified Data.Text as Text
 
+import Data.Proxy (Proxy(..))
+
+
+$(sqlInTuples [2..16])
+
 
 data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
 
@@ -270,13 +277,14 @@ instance Default DBStyle where
     , dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default")
     }
 
-data DBTable m x = forall a r r' h i t.
+data DBTable m x = forall a r r' h i t k k'.
   ( ToSortable h, Functor h
-  , E.SqlSelect a r
+  , E.SqlSelect a r, SqlIn k k', ToJSON k', FromJSON k', Eq k'
   , PathPiece i, Eq i
   , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
   ) => DBTable
   { dbtSQLQuery :: t -> E.SqlQuery a
+  , dbtRowKey :: t -> k
   , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
   , dbtColonnade :: Colonnade h r' (DBCell m x)
   , dbtSorting :: Map SortingKey (SortColumn t)
@@ -297,10 +305,10 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x), Default (DBParams m x)) =>
 
   -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
   -- | Format @DBTable@ when sort-circuiting
-  dbWidget   :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget
+  dbWidget   :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> DBResult m x -> m' Widget
   -- | Format @DBTable@ when not short-circuiting
-  dbHandler  :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> (Widget -> Widget) -> DBResult m x -> m' (DBResult 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'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> m (x, Widget) -> ReaderT SqlBackend 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)
 
 cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
 cellAttrs = dbCell . _1
@@ -325,7 +333,7 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
   -- dbWidget Proxy Proxy = iso (, ()) $ view _1
   dbWidget _ _ = return . snd
   dbHandler _ _ f = return . over _2 f
-  runDBTable _ _ = liftHandlerT
+  runDBTable _ _ _ = liftHandlerT
 
 instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
   mempty = WidgetCell mempty $ return mempty
@@ -350,7 +358,7 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
   dbWidget _ _ = return . snd
   dbHandler _ _ f = return . over _2 f
   -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
-  runDBTable _ _ = mapReaderT liftHandlerT
+  runDBTable _ _ _ = mapReaderT liftHandlerT
 
 instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
   mempty = DBCell mempty $ return mempty
@@ -390,7 +398,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
   -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
   -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
   -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
-  runDBTable dbtable pi = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenField dbtable pi . withFragment
+  runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenFields dbtable pi pKeys . withFragment
 
 instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
   def = DBParamsForm
@@ -413,10 +421,13 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do
         enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype
     $(widgetFile "table/form-wrap")
 
-addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a
+addPIHiddenFields :: ToJSON k' => DBTable m x -> PaginationInput -> [k'] -> Form a -> Form a
-addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet|
+addPIHiddenFields DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi pKeys form fragment = do
+  encrypted <- encodedSecretBox SecretBoxShort pKeys
+  form $ fragment <> [shamlet|
     $newline never
     <input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
+    <input type=hidden name=#{wIdent "previous"} value=#{encrypted}>
   |]
   where
     wIdent n
@@ -453,6 +464,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       }
 
   piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
+  previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
 
   piInput <- lift . runInputGetResult $ PaginationInput
     <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
@@ -483,7 +495,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       FormFailure errs'
           -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
       _   -> runPSValidator dbtable Nothing
-    paginationInput
+    paginationInput@PaginationInput{..}
       | FormSuccess pi <- piResult
       , not $ piIsUnset pi
       = pi
@@ -496,24 +508,41 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
   rows' <- E.select . E.from $ \t -> do
     res <- dbtSQLQuery t
     E.orderBy (map (sqlSortDirection t) psSorting')
-    E.limit psLimit
+    case previousKeys of
-    E.offset (psPage * psLimit)
+      Nothing -> do
+        E.limit psLimit
+        E.offset (psPage * psLimit)
+      Just ps -> E.where_ $ dbtRowKey t `sqlIn` ps
     Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
-    return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), res)
+    return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
 
-  let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)
+  let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v)
 
-  rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
+  (currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) $ zip [succ (psPage * psLimit)..] rows'
 
   getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+  let
+    tblLink :: (QueryText -> QueryText) -> Text
+    tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ (f . substPi) getParams
+    substPi = foldr (.) id
+      [ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
+      , foldr (.) id . map (\k -> setParams (wIdent $ toPathPiece k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
+      , setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
+      , setParam (wIdent "page") $ fmap toPathPiece piPage
+      ]
+
+  if
+    | Just pKeys <- previousKeys
+    , pKeys /= currentKeys
+      -> redirectWith preconditionFailed412 $ tblLink id
+    | otherwise
+      -> return ()
 
   let
     rowCount
-      | (E.Value n, _):_ <- rows' = n
+      | (E.Value n, _, _):_ <- rows' = n
       | otherwise = 0
 
-    tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ f getParams
-
     filterAction = tblLink
       $ setParam (wIdent "page") Nothing
       . Map.foldrWithKey (\k _ f -> setParam (wIdent $ toPathPiece k) Nothing . f) id dbtFilter
@@ -547,15 +576,18 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
       return $(widgetFile "table/layout")
 
-  bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable dbtable paginationInput . fmap swap $ runWriterT table'
+  bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< 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
       tbl <- liftHandlerT $ widgetToPageContent tbl'
       withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
 
+    setParams :: Text -> [Text] -> QueryText -> QueryText
+    setParams key vs qt = map ((key, ) .  Just) vs ++ [ i | i@(key', _) <- qt, key' /= key ]
+  
     setParam :: Text -> Maybe Text -> QueryText -> QueryText
-    setParam key v qt = maybe id (\v' -> (:) (key, Just v')) v [ i | i@(key', _) <- qt, key' /= key ]
+    setParam key = setParams key . maybeToList
 
 dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
     -> DB (DBResult (HandlerT UniWorX IO) x)

src/Handler/Utils/Table/Pagination/Types.hs

@@ -6,6 +6,8 @@ module Handler.Utils.Table.Pagination.Types
   , sortable
   , ToSortable(..)
   , SortableP(..)
+  , SqlIn(..)
+  , sqlInTuples
   ) where
 
 import Import hiding (singleton)
@@ -17,6 +19,13 @@ import Data.CaseInsensitive (CI)
 
 import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
 
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
+
+import Language.Haskell.TH
+
+import Data.List (foldr1, foldl)
+
 
 newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
   deriving (Show, Read)
@@ -55,3 +64,35 @@ instance ToSortable Headed where
 
 instance ToSortable Headless where
   pSortable = Nothing
+
+
+class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
+  sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
+
+instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
+  x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
+
+sqlInTuples :: [Int] -> DecsQ
+sqlInTuples = mapM sqlInTuple
+
+sqlInTuple :: Int -> DecQ
+sqlInTuple arity = do
+  tyVars <- replicateM arity $ newName "t"
+  vVs <- replicateM arity $ newName "v"
+  xVs <- replicateM arity $ newName "x"
+  xsV <- newName "xs"
+
+  let
+    matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
+    tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
+  
+  instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
+    [ funD 'sqlIn
+      [ clause [tupP $ map varP xVs, varP xsV]
+        ( guardedB
+          [ normalGE [e|null $(varE xsV)|] [e|E.val False|]
+          , normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|]
+          ]
+        ) []
+      ]
+    ]

src/Model/Types.hs

@@ -77,6 +77,8 @@ import Data.Data (Data)
 import Model.Types.Wordlist
 import Data.Text.Metrics (damerauLevenshtein)
 
+import qualified Database.Esqueleto as E
+
 instance PathPiece UUID where
   fromPathPiece = UUID.fromString . unpack
   toPathPiece = pack . UUID.toString
@@ -100,6 +102,12 @@ instance ToHttpApiData (CI Text) where
 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 Points = Centi

src/Utils.hs

@@ -371,6 +371,9 @@ instance Ord a => Ord (NTop (Maybe a)) where
   compare _               (NTop Nothing) = LT
   compare (NTop (Just x)) (NTop (Just y)) = compare x y
 
+exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
+exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT
+
 
 ------------
 -- Either --