130 lines
3.9 KiB
Haskell
130 lines
3.9 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
|
|
module Handler.Utils
|
|
( module Handler.Utils
|
|
) where
|
|
|
|
|
|
|
|
import Import.NoFoundation
|
|
|
|
import Handler.Utils.DateTime as Handler.Utils
|
|
import Handler.Utils.Term as Handler.Utils
|
|
import Handler.Utils.Form as Handler.Utils
|
|
import Handler.Utils.Table as Handler.Utils
|
|
import Handler.Utils.Table.Pagination as Handler.Utils
|
|
|
|
import Handler.Utils.Zip as Handler.Utils
|
|
import Handler.Utils.Rating as Handler.Utils
|
|
import Handler.Utils.Submission as Handler.Utils
|
|
import Handler.Utils.Templates as Handler.Utils
|
|
|
|
import Text.Blaze (Markup, ToMarkup)
|
|
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
import qualified Data.List as List
|
|
|
|
import Database.Persist.Class
|
|
|
|
tickmark :: IsString a => a
|
|
tickmark = fromString "✔"
|
|
|
|
text2Html :: Text -> Html
|
|
text2Html = toHtml -- prevents ambiguous types
|
|
|
|
toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
|
|
a -> WidgetT site m ()
|
|
toWgt = toWidget . toHtml
|
|
|
|
text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
|
|
Text -> WidgetT site m ()
|
|
text2widget t = [whamlet|#{t}|]
|
|
|
|
str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
|
|
String -> WidgetT site m ()
|
|
str2widget s = [whamlet|#{s}|]
|
|
|
|
|
|
withFragment :: ( Monad m
|
|
) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
|
|
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
|
|
|
|
-----------
|
|
-- Maybe --
|
|
-----------
|
|
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
|
whenIsJust (Just x) f = f x
|
|
whenIsJust Nothing _ = return ()
|
|
|
|
|
|
|
|
----------
|
|
-- Maps --
|
|
----------
|
|
entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
|
|
entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
|
|
|
|
|
|
------------
|
|
-- Routes --
|
|
------------
|
|
|
|
-- -- redirectBack :: Handler Html
|
|
-- -- redirectBack :: HandlerT UniWorX IO Html
|
|
-- redirectBack = defaultLayout $ do
|
|
-- [whamlet| BACK |]
|
|
-- -- [julius| window.history.back(); |]
|
|
|
|
|
|
--------------
|
|
-- Database --
|
|
--------------
|
|
|
|
-- getKeyBy :: PersistEntity val => Unique val -> ReaderT backend0 m0 (Maybe (Entity val))
|
|
-- getKeyBy :: Unique a -> YesodDB site (Key a)
|
|
|
|
getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
|
=> Unique record -> ReaderT backend m (Maybe (Key record))
|
|
getKeyBy u = (fmap entityKey) <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
|
|
|
|
getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
|
=> Unique record -> ReaderT backend m (Key record)
|
|
getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
|
|
|
|
|
|
myReplaceUnique
|
|
:: (MonadIO m
|
|
,Eq (Unique record)
|
|
,PersistRecordBackend record backend
|
|
,PersistUniqueWrite backend)
|
|
=> Key record -> record -> ReaderT backend m (Maybe (Unique record))
|
|
myReplaceUnique key datumNew = getJust key >>= replaceOriginal
|
|
where
|
|
uniqueKeysNew = persistUniqueKeys datumNew
|
|
replaceOriginal original = do
|
|
conflict <- checkUniqueKeys changedKeys
|
|
case conflict of
|
|
Nothing -> replace key datumNew >> return Nothing
|
|
(Just conflictingKey) -> return $ Just conflictingKey
|
|
where
|
|
changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal
|
|
uniqueKeysOriginal = persistUniqueKeys original
|
|
|
|
checkUniqueKeys
|
|
:: (MonadIO m
|
|
,PersistEntity record
|
|
,PersistUniqueRead backend
|
|
,PersistRecordBackend record backend)
|
|
=> [Unique record] -> ReaderT backend m (Maybe (Unique record))
|
|
checkUniqueKeys [] = return Nothing
|
|
checkUniqueKeys (x:xs) = do
|
|
y <- getBy x
|
|
case y of
|
|
Nothing -> checkUniqueKeys xs
|
|
Just _ -> return (Just x)
|