lmonad-yesod 0.3.0.0 → 1.0.0.0
raw patch · 3 files changed
+20/−16 lines, 3 files
Files
- lmonad-yesod.cabal +1/−1
- src/Database/LPersist.hs +14/−12
- src/Database/LPersist/Labeler.hs +5/−3
lmonad-yesod.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.3.0.0+version: 1.0.0.0 -- A short (one-line) description of the package. synopsis: LMonad for Yesod integrates LMonad's IFC with Yesod web applications.
src/Database/LPersist.hs view
@@ -31,6 +31,7 @@ , YesodLPersist (..) , lDefaultRunDB , ProtectedEntity(..)+ , Protected , PEntity(..) , get , pGet@@ -91,11 +92,12 @@ -- | Typeclass for protected entities. -- `mkLabels` automatically generates these instances.-class Label l => ProtectedEntity l e p | e -> p where- toProtected :: LMonad m => Entity e -> LMonadT l m p+type family Protected e+class Label l => ProtectedEntity l e where+ toProtected :: LMonad m => Entity e -> LMonadT l m (Protected e) -- | ADT wrapper for protected entities. Analagous to Entity.-data PEntity l e = forall p . (ProtectedEntity l e p) => PEntity (Key e) p+data PEntity l e = (ProtectedEntity l e) => PEntity (Key e) (Protected e) -- | How to run database functions. @@ -121,7 +123,7 @@ whenJust res $ lift . raiseLabelRead . (Entity key) return res -pGet :: (ProtectedEntity l v p, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Key v -> ReaderT backend (LMonadT l m) (Maybe p)+pGet :: (ProtectedEntity l v, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Key v -> ReaderT backend (LMonadT l m) (Maybe (Protected v)) pGet key = do res <- Persist.get key maybe (return Nothing) handler res@@ -184,7 +186,7 @@ where err = liftIO $ throwIO $ Persist.KeyNotFound $ Prelude.show key -pUpdateGet :: (backend ~ SqlBackend, ProtectedEntity l v p, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (Key v) -> [Update v] -> ReaderT backend (LMonadT l m) p+pUpdateGet :: (backend ~ SqlBackend, ProtectedEntity l v, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => (Key v) -> [Update v] -> ReaderT backend (LMonadT l m) (Protected v) pUpdateGet key = updateHelper err (toProtected . (Entity key)) key where err = liftIO $ throwIO $ Persist.KeyNotFound $ Prelude.show key@@ -194,7 +196,7 @@ where err = liftIO $ throwIO $ Persist.PersistForeignConstraintUnmet $ Text.pack $ Prelude.show key -pGetJust :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v, ProtectedEntity l v p) => (Key v) -> ReaderT backend (LMonadT l m) p+pGetJust :: (LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v, ProtectedEntity l v) => (Key v) -> ReaderT backend (LMonadT l m) (Protected v) pGetJust key = pGet key >>= maybe err return where err = liftIO $ throwIO $ Persist.PersistForeignConstraintUnmet $ Text.pack $ Prelude.show key@@ -210,7 +212,7 @@ whenJust res $ lift . raiseLabelRead return res -pGetBy :: (ProtectedEntity l v p, PersistUnique backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Unique v -> ReaderT backend (LMonadT l m) (Maybe (PEntity l v))+pGetBy :: (ProtectedEntity l v, PersistUnique backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Unique v -> ReaderT backend (LMonadT l m) (Maybe (PEntity l v)) pGetBy uniq = do res <- Persist.getBy uniq lift $ mapM toProtectedWithKey res@@ -220,14 +222,14 @@ -- return $ Just $ PEntity (entityKey ent) pEnt -- ) res -deleteBy :: (ProtectedEntity l v p, PersistUnique backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Unique v -> ReaderT backend (LMonadT l m) ()+deleteBy :: (ProtectedEntity l v, PersistUnique backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => Unique v -> ReaderT backend (LMonadT l m) () deleteBy uniq = do res <- Persist.getBy uniq whenJust res $ \e -> do lift $ raiseLabelWrite e Persist.deleteBy uniq -insertUnique :: (ProtectedEntity l v p, PersistUnique backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => v -> ReaderT backend (LMonadT l m) (Maybe (Key v))+insertUnique :: (ProtectedEntity l v, PersistUnique backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v) => v -> ReaderT backend (LMonadT l m) (Maybe (Key v)) insertUnique val = do lift $ raiseLabelCreate val Persist.insertUnique val@@ -266,12 +268,12 @@ whenJust res $ lift . raiseLabelRead return res -toProtectedWithKey :: (LMonad m, ProtectedEntity l e p) => Entity e -> LMonadT l m (PEntity l e)+toProtectedWithKey :: (LMonad m, ProtectedEntity l e) => Entity e -> LMonadT l m (PEntity l e) toProtectedWithKey r = do p <- toProtected r return $ PEntity (entityKey r) p -pSelectFirst :: (PersistQuery backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v, ProtectedEntity l v p) => [Filter v] -> [SelectOpt v] -> ReaderT backend (LMonadT l m) (Maybe (PEntity l v))+pSelectFirst :: (PersistQuery backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v, ProtectedEntity l v) => [Filter v] -> [SelectOpt v] -> ReaderT backend (LMonadT l m) (Maybe (PEntity l v)) pSelectFirst filts opts = do res <- Persist.selectFirst filts opts lift $ mapM toProtectedWithKey res@@ -292,7 +294,7 @@ lift $ mapM_ raiseLabelRead l return l -pSelectList :: (PersistQuery backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v, ProtectedEntity l v p) => [Filter v] -> [SelectOpt v] -> ReaderT backend (LMonadT l m) [PEntity l v]+pSelectList :: (PersistQuery backend, LMonad m, Label l, LEntity l v, MonadIO m, PersistStore backend, backend ~ PersistEntityBackend v, PersistEntity v, ProtectedEntity l v) => [Filter v] -> [SelectOpt v] -> ReaderT backend (LMonadT l m) [PEntity l v] pSelectList filts opts = do l <- Persist.selectList filts opts lift $ mapM toProtectedWithKey l
src/Database/LPersist/Labeler.hs view
@@ -32,7 +32,7 @@ labelFs <- mapM (mkLabelEntity labelType) entsL lEntityInstance <- mapM (mkLEntityInstance labelType) entsL protected <- mapM (mkProtectedEntity labelType) entsL- protectedInstance <- mapM (mkProtectedEntityInstance labelType) entsL+ protectedInstance <- mconcat <$> mapM (mkProtectedEntityInstance labelType) entsL -- let serializedLEntityDef = mkSerializedLEntityDefs entsL return $ concat [concat labelFs, labelFs', lEntityInstance, protected, protectedInstance] -- , serializedLEntityDef] @@ -298,13 +298,15 @@ -- let admin = userAdmin _e -- return $ ProtectedUser ident password email admin -mkProtectedEntityInstance :: Type -> LEntityDef -> Q Dec+mkProtectedEntityInstance :: Type -> LEntityDef -> Q [Dec] mkProtectedEntityInstance labelType ent = do ( fStmts, fExps) <- foldM mkProtectedFieldInstance ([],[]) $ lEntityFields ent let recordCons = RecConE (mkName pName) fExps let body = DoE $ fStmts ++ [NoBindS (AppE (VarE (mkName "return")) recordCons)] let toProtected = FunD (mkName "toProtected") [Clause [AsP entity (ConP (mkName "Entity") [VarP eId,VarP e])] (NormalB body) []]- return $ InstanceD [] (AppT (AppT (AppT (ConT (mkName "ProtectedEntity")) labelType) (ConT (mkName eName))) (ConT (mkName pName))) [toProtected]+ let inst = InstanceD [] (AppT (AppT (ConT (mkName "ProtectedEntity")) labelType) (ConT (mkName eName))) [toProtected]+ let typInst = TySynInstD (mkName "Protected") $ TySynEqn [ConT (mkName eName)] (ConT $ mkName pName)+ return [inst, typInst] where eName = lEntityHaskell ent