typed-admin (empty) → 0.1.0.0
raw patch · 17 files changed
+1540/−0 lines, 17 filesdep +HDBCdep +HDBC-postgresqldep +HDBC-sessionsetup-changed
Dependencies added: HDBC, HDBC-postgresql, HDBC-session, base, blaze-markup, bytestring, data-default-class, exceptions, generic-lens, heterocephalus, http-api-data, http-types, lens, lucid, monad-control, mtl, persistable-record, relational-query, relational-query-HDBC, relational-record, template-haskell, text, time, transformers, transformers-base, typed-admin, unordered-containers, utf8-string, wai, wai-extra, warp, yaml
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- app/DataSource2.hs +47/−0
- app/Entity/Beer.hs +14/−0
- app/Entity/BeerImage.hs +14/−0
- app/Entity/Store.hs +14/−0
- app/Main.hs +171/−0
- src/TypedAdmin.hs +258/−0
- src/TypedAdmin/Class.hs +176/−0
- src/TypedAdmin/Extra.hs +96/−0
- src/TypedAdmin/Instance.hs +457/−0
- src/TypedAdmin/Router.hs +86/−0
- src/TypedAdmin/Util.hs +20/−0
- templates/javascript/map.js +24/−0
- typed-admin.cabal +127/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for typed-admin++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# typed-admin
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/DataSource2.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleContexts #-}++module DataSource2 where++import Control.Monad.IO.Class+import Database.HDBC (commit, disconnect)+import Database.HDBC.PostgreSQL (Connection, connectPostgreSQL)+import Database.HDBC.Query.TH (defineTableFromDB)+import Database.HDBC.Record+import Database.HDBC.Schema.Driver (typeMap)+import Database.HDBC.Schema.PostgreSQL (driverPostgreSQL)+import Language.Haskell.TH (Dec, Name, Q, TypeQ)++-- createPool' config = createPool (connect config) disconnect (dbPoolStripeNum config) (realToFrac (dbPoolKeepTime config)) (dbPoolResourceNum config)++connect :: IO Connection+connect =+ connectPostgreSQL $ concat [+ "user='", "admin", "'"+ , "password='", "admin", "'"+ , "dbname='", "admin", "'"+ , "host='", "localhost", "'"+ , "port='", "15432", "'"+ ]++-- connectWithLoadConfig :: IO Connection+-- connectWithLoadConfig = do+-- c <- loadConfig+-- connect c++defineTable :: String -> [Name] -> Q [Dec]+defineTable =+ defineTableFromDB+ connect+ (driverPostgreSQL { typeMap = convTypes })+ "public"++convTypes :: [(String, TypeQ)]+convTypes = []+++runQuery a b = liftIO $ do+ conn <- liftIO connect+ runQuery' conn a b+insertM a b = liftIO connect >>= \conn -> liftIO $ runInsert conn a b >> commit conn+deleteM a b = liftIO connect >>= \conn -> liftIO $ runDelete conn a b >> commit conn+updateM a b = liftIO connect >>= \conn -> liftIO $ runUpdate conn a b >> commit conn
+ app/Entity/Beer.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++module Entity.Beer where++import Database.Relational+import DataSource2 (defineTable)+import GHC.Generics+import Prelude hiding (id)++$(defineTable "beer" [''Show, ''Generic, ''Eq])
+ app/Entity/BeerImage.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++module Entity.BeerImage where++import Database.Relational+import DataSource2 (defineTable)+import GHC.Generics+import Prelude hiding (id)++$(defineTable "beer_image" [''Show, ''Generic, ''Eq])
+ app/Entity/Store.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++module Entity.Store where++import Database.Relational+import DataSource2 (defineTable)+import GHC.Generics+import Prelude hiding (id)++$(defineTable "store" [''Show, ''Generic, ''Eq])
+ app/Main.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Main where++import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Data.Default.Class+import Data.Generics.Labels ()+import Data.Maybe+import Data.Proxy+import Data.Text as T+import Database.Relational as R hiding (fromMaybe, list)+import DataSource2+import Debug.Trace (trace)+import qualified Entity.Beer as Beer+import qualified Entity.Store as Store+import GHC.Generics+import GHC.Int+import Lucid+import Network.HTTP.Types (status404)+import Network.Wai+import Network.Wai.Handler.Warp (run)+import Prelude hiding (id)+import qualified Prelude (id)+import TypedAdmin+import TypedAdmin.Util++instance Default Beer.Beer++instance ToDetail Handler Beer.Beer++instance ToForm Handler Beer.Beer++data BeerDetail = BeerDetail+ { id :: Int64+ , name :: String+ , ibu :: Maybe Int32+ } deriving (Generic)++data UpdateBeerParam = UpdateBeerParam+ { name :: String+ , ibu :: Maybe Int32+ } deriving (Generic)++instance ToForm Handler UpdateBeerParam++data BeerSummary = BeerSummary+ { id :: Int64+ , name :: String+ , images :: [Image]+ } deriving (Generic, Show)++instance HasHeader BeerSummary++instance ToDetail Handler BeerSummary where+ linkDetail x =+ pure $ Just $ "/beers/" <> tshow (x ^. #id)+ linkEdit x =+ pure $ Just $ "/beers/" <> tshow (x ^. #id) <> "/_edit"++instance ToDetail Handler BeerDetail++instance ToDetail Handler Store.Store+instance HasHeader Store.Store++data SearchBeerParam = SearchBeerParam+ { name :: Maybe String+ , ibu :: Maybe Int32+ } deriving (Generic, Show)++instance ToForm Handler SearchBeerParam++instance ListConsole Handler BeerSummary SearchBeerParam where+ list p _ = do+ beers <- runQuery (relationalQuery' (f p) []) ()+ return $ fmap r beers+ where+ f (param :: Maybe SearchBeerParam) = relation $ do+ x <- query Beer.beer+ whenJust (param ^? _Just . #name . _Just) $ \v -> wheres $ x ! Beer.name' .=. value v+ whenJust (param ^? _Just . #ibu . _Just) $ \v -> wheres $ x ! Beer.ibu' .=. just (value v)+ return x+ -- mock+ r x = BeerSummary+ { id = Beer.id x+ , name = Beer.name x+ , images = fmap Image ["https://source.unsplash.com/100x100/?beer"]+ }+ listSublayout _ _ b = do+ div_ [] $+ a_ [href_ "/beers/_create"] "add new beer"+ div_ [] b++instance ListConsole Handler Store.Store () where+ list x _ = runQuery (relationalQuery' Store.store []) ()++instance DetailConsole Handler Beer.Beer where+ type Ident Beer.Beer = Int64+ detail i = one <$> runQuery Beer.selectBeer i++instance CreateConsole Handler Beer.Beer Beer.Beer where+ create _ x = do+ insertM Beer.insertBeer x+ pure ()+ createdRedirectPath _ _ = pure "/beers"+ detailForCreate _ _ = pure . Just $ def++toDetailUrl x = "/beers/" `append` (pack . show $ Beer.id x)++instance EditConsole Handler BeerDetail UpdateBeerParam where+ type EditIdent BeerDetail UpdateBeerParam = Int64+ editedRedirectPath _ _ ident = pure $ "/beers/" <> tshow ident <> "/_edit"+ detailForEdit _ ident = do+ b <- one <$> runQuery Beer.selectBeer ident+ case b of+ Just b ->+ return $ Just $ BeerDetail (Beer.id b) (Beer.name b) (Beer.ibu b)+ Nothing -> return Nothing+ edit _ ident x = updateM f ()+ where+ f :: Update ()+ f = update $ \proj -> do+ Beer.name' <-# value (x ^. #name)+ Beer.ibu' <-# value (x ^. #ibu)+ wheres $ proj ! Beer.id' .=. value ident+ return unitPlaceHolder++route :: [Route Handler]+route =+ [ ListR "beers" (Proxy :: Proxy BeerSummary) (Proxy :: Proxy SearchBeerParam)+ , DetailR ("beers" </> var @Int64) (Proxy :: Proxy Beer.Beer)+ , CreateR "beers" (Proxy :: Proxy Beer.Beer) (Proxy :: Proxy Beer.Beer)+ , EditR ("beers" </> var @Int64) (Proxy :: Proxy BeerDetail) (Proxy :: Proxy UpdateBeerParam)+ , ListR "stores" (Proxy :: Proxy Store.Store) (Proxy :: Proxy ())+ ]++application :: forall b . Request -> (Response -> IO b) -> IO b+application req res = res $ responseLBS status404 [("Content-Type", "text/plain")] "not found"++serve = do+ putStrLn "http://localhost:3000/beers"+ dic <- loadDictionary "i18n.yaml"+ run 3000 $ admin route Prelude.id Nothing (either (const Nothing) Just dic) application+main = serve++-- util++memptyToNothing x = if x == mempty then Nothing else Just x++one (x:_) = Just x+one _ = Nothing++debug lbl x = trace (lbl ++ ": " ++ show x) x++tshow :: Show a => a -> Text+tshow = pack . show
+ src/TypedAdmin.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TypedAdmin+ ( module TypedAdmin.Class+ , module TypedAdmin.Instance+ , module TypedAdmin.Router+ , module TypedAdmin.Extra+ , module TypedAdmin+ ) where++import Control.Monad.State.Class+import Control.Monad.State.Strict+import qualified Data.ByteString.Lazy.UTF8 as LBS+import qualified Data.ByteString.UTF8 as BS+import Data.Maybe+import Data.Proxy+import Data.Text (unpack)+import Data.Yaml as Y+import Lucid+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Parse+import TypedAdmin.Class+import TypedAdmin.Extra+import TypedAdmin.Instance+import TypedAdmin.Router+import TypedAdmin.Util++type Layout m = HtmlT m () -> HtmlT m ()++runHandler' ctx a = evalStateT (runHandler a) ctx++admin :: forall m a.+ MonadState Context m => [Route m]+ -> (forall x. m x -> Handler x)+ -> Maybe (Layout m)+ -> Maybe Dic+ -> Middleware+admin rt nt layout dic = \app -> \req res -> do+ let ctx = Context dic []+ case (requestMethod req, pathInfo req) of+ (method, ps) -> do+ let+ f "GET" (ListR path p1 p2) =+ case fromPath path (Prelude.reverse ps) of+ Just () ->+ Just $ handleListConsole nt req res (path, ()) layout ctx p1 p2+ _ -> Nothing+ f "GET" (DetailR path p1) = do+ case fromPath path (Prelude.reverse ps) of+ Just x ->+ Just $ handleDetailConsole nt req res p1 ctx x+ _ -> Nothing+ f "GET" (CreateR path p1 p2) = do+ case fromPath (StaticP "_create" path) (Prelude.reverse ps) of+ Just () ->+ Just $ handleCreateConsole nt req res (path, ()) layout ctx p1 p2+ _ -> Nothing+ f "POST" (CreateR path p1 p2) = do+ case fromPath (path) (Prelude.reverse ps) of+ Just () ->+ Just $ handleCreate nt req res p1 p2 ctx+ _ -> Nothing+ f "GET" (EditR path p1 p2) = do+ case fromPath (StaticP "_edit" path) (reverse ps) of+ Just x ->+ Just $ handleEditConsole nt req res (path, x) layout p1 p2 ctx x+ _ -> Nothing+ f "POST" (EditR path p1 p2) = do+ handleEdit nt req res p1 p2 ctx <$> fromPath path (reverse ps)+ f "POST" (DeleteR path p1) = do+ case fromPath (StaticP "_delete" path) (reverse ps) of+ Just x ->+ Just $ handleDelete nt req res p1 ctx x+ _ -> Nothing+ f _ _ = Nothing+ case firstJust (f method) rt of+ Just h -> h+ Nothing -> app req res++-- newtype Handler a = Handler { runHandler :: IO a }++contentType = ("Content-Type", "Content-type: text/html; charset=UTF-8")++-- todo:: receive func like (m - IO)++handleListConsole :: forall proxy1 proxy2 p1 p2 z m a b.+ (ListConsole m p1 p2, PathParam a b, MonadState Context m)+ => (forall x . m x -> Handler x)+ -> Request+ -> (Response -> IO z)+ -> (a, b)+ -> Maybe (Layout m)+ -> Context+ -> proxy1 p1+ -> proxy2 p2+ -> IO z+handleListConsole nt req res (path, param) layout ctx _ _ = do+ let query = queryString req+ let page = fromMaybe 0 $ lookupMaybe "page" query+ let+ f :: m LBS.ByteString+ f = do+ p <- r2m <$> fromForm query+ beers <- (list :: (Maybe p2) -> Page -> m ([p1])) p page+ mtotal <- total p (Proxy :: Proxy p1)+ let body = renderListHtml beers p (path, param, query) (page, mtotal)+ renderBST $ (fromMaybe defaultLayout layout) body+ body <- runHandler' ctx $ nt f+ res $+ responseLBS status200 [contentType] body++r2m (Right x) = Just x+r2m _ = Nothing++handleDetailConsole :: forall proxy1 p1 b m.+ (DetailConsole m p1, MonadState Context m)+ => (forall x . m x -> Handler x)+ -> Request+ -> (Response -> IO b)+ -> proxy1 p1+ -> Context+ -> Ident p1+ -> IO b+handleDetailConsole nt req res _ ctx rid = do+ mbody <- runHandler' ctx $ nt $ do+ mr <- detail rid :: m (Maybe p1)+ case mr of+ Just r -> do+ Just <$> renderBST (renderDetailHtml r)+ Nothing -> pure Nothing+ case mbody of+ Just x ->+ res $ responseLBS status200 [("Content-Type", "text/html")] x+ Nothing ->+ res404 res++handleCreateConsole :: forall proxy1 proxy2 a b z m c d.+ (CreateConsole m a b, PathParam c d)+ => (forall x. m x -> Handler x)+ -> Request+ -> (Response -> IO z)+ -> (c, d)+ -> Maybe (Layout m)+ -> Context+ -> proxy1 a+ -> proxy2 b+ -> IO z+handleCreateConsole nt req res path layout ctx _ _ = do+ let query = queryString req+ body <- runHandler' ctx $ nt $ do+ mr <- detailForCreate query (Proxy :: Proxy b) :: m (Maybe a)+ case mr of+ Just r ->+ Just <$> (renderBST $ (fromMaybe defaultLayout layout) (toCreateForm r (Proxy :: Proxy b) path))+ Nothing ->+ pure Nothing+ case body of+ Just x ->+ res $ responseLBS status200 [contentType] x+ Nothing -> res404 res++handleCreate :: forall proxy1 proxy2 a b z m. (CreateConsole m a b)+ => (forall x. m x -> Handler x)+ -> Request+ -> (Response -> IO z)+ -> proxy1 a+ -> proxy2 b+ -> Context+ -> IO z+handleCreate nt req res _ _ ctx = do+ (ps, _) <- parseRequestBody lbsBackEnd req+ mx <- runHandler' ctx $ nt $ fromForm (mapSnd Just <$> ps)+ case mx of+ Right x -> do+ path <- runHandler' ctx $ nt $ do+ create (Proxy :: Proxy a) (x :: b)+ createdRedirectPath (Proxy :: Proxy a) (x :: b)+ res $ responseLBS status302 [contentType, ("Location", BS.fromString $ unpack path)] "not found"+ Left x -> res400 res (LBS.fromString x)++handleEditConsole :: forall proxy1 proxy2 a b c d z m.+ (EditConsole m a b, PathParam c d, MonadState Context m)+ => (forall x. m x -> Handler x)+ -> Request+ -> (Response -> IO z)+ -> (c, d)+ -> Maybe (Layout m)+ -> proxy1 a+ -> proxy2 b+ -> Context+ -> EditIdent a b+ -> IO z+handleEditConsole nt req res path layout _ _ ctx rid = do+ body <- runHandler' ctx $ nt $ do+ mr <- detailForEdit (Proxy :: Proxy b) rid :: m (Maybe a)+ case mr of+ Just r ->+ renderBST $ (fromMaybe defaultLayout layout) (renderEditHtml r (Proxy :: Proxy b) rid path)+ res $+ responseLBS status200 [contentType] body++handleEdit :: forall proxy1 proxy2 a b z m. (EditConsole m a b)+ => (forall x. m x -> Handler x)+ -> Request+ -> (Response -> IO z)+ -> proxy1 a+ -> proxy2 b+ -> Context+ -> EditIdent a b+ -> IO z+handleEdit nt req res _ _ ctx rid = do+ (ps, _) <- parseRequestBody lbsBackEnd req+ mx <- runHandler' ctx $ nt $ fromForm (mapSnd Just <$> ps)+ case mx of+ Right x -> do+ editP <- runHandler' ctx $ nt $ do+ edit (Proxy :: Proxy a) rid (x :: b)+ editedRedirectPath (Proxy :: Proxy a) (Proxy :: Proxy b) rid+ res $ responseLBS status302 [contentType, ("Location", BS.fromString $ unpack editP)] "not found"+ Left x -> res400 res (LBS.fromString x)++handleDelete :: forall proxy1 a z m. (DeleteConsole m a)+ => (forall x. m x -> Handler x)+ -> Request+ -> (Response -> IO z)+ -> proxy1 a+ -> Context+ -> DeleteIdent a+ -> IO z+handleDelete nt req res _ ctx rid = do+ (ps, _) <- parseRequestBody lbsBackEnd req+ mx <- runHandler' ctx $ nt $ fromForm (mapSnd Just <$> ps)+ case mx of+ Right x -> do+ editP <- runHandler' ctx $ nt $ do+ delete rid (x :: a)+ deletedRedirectPath rid x+ res $ responseLBS status302 [contentType, ("Location", BS.fromString $ unpack editP)] "not found"+ Left x -> res400 res (LBS.fromString x)++res400 res str = res $ responseLBS status400 [("Content-Type", "text/plain")] str+res404 res = res $ responseLBS status404 [("Content-Type", "text/plain")] "not found"++defaultLayout :: Monad m => HtmlT m a -> HtmlT m a+defaultLayout x = do+ doctypehtml_ $ do+ head_ [] $ return ()+ body_ [] x++loadDictionary :: FilePath -> IO (Either ParseException Dic)+loadDictionary path = do+ decodeFileEither path
+ src/TypedAdmin/Class.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module TypedAdmin.Class where++import Control.Monad.Base (MonadBase)+import Control.Monad.Catch hiding (Handler)+import Control.Monad.IO.Class+import Control.Monad.State.Class+import Control.Monad.State.Strict+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.ByteString+import Data.Generics.Product.Subtype+import Data.Proxy+import Data.Text (Text)+import qualified Data.Yaml as Y+import GHC.Generics+import Lucid (HtmlT (..))+import Network.HTTP.Types+++type PathText = Text+type Page = Int++type Dic = Y.Object+data Context = Context+ { dic :: Maybe Dic+ , localeHierarchy :: [Text]+ }+class MonadState Context m => L18N m++-- class Monad m => MonadState' r (m :: * -> *) | m -> r where+-- ask' :: m r+-- local' :: (r -> r) -> m a -> m a+-- reader' :: (r -> a) -> m a++-- instance Monad m => MonadState' r (ReaderT r m) where+-- ask' = ask+-- local' = local+-- reader' = reader++-- instance MonadState' r m => MonadState' r (HtmlT m) where+-- ask' = lift ask'+-- local' f a = a++-- asks' :: MonadState' r m => (r -> a) -> m a+-- asks' = reader'++newtype Handler a = Handler+ { runHandler :: StateT Context IO a+ } deriving+ ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadState Context+ , MonadBase IO+ , MonadBaseControl IO+ , MonadThrow+ , MonadCatch+ )++-- class ToName a where+-- toName :: proxy a -> Text++class HasHeader a where+ hasHeader :: (Monad m, MonadState Context m) => proxy a -> [HtmlT m ()]+ default hasHeader:: (Monad m, MonadState Context m, Generic a, GHasHeader (Rep a)) => proxy a -> [HtmlT m ()]+ hasHeader x = gHasHeader (Proxy :: Proxy (Rep a))++class GHasHeader (f :: * -> *) where+ gHasHeader :: (Monad m, MonadState Context m) => proxy f -> [HtmlT m ()]++class ToDetailField a where+ toDetailField :: Monad m => a -> HtmlT m ()++class MonadIO m => ToDetail m f where+ toDetail :: f -> m [(Text, HtmlT m ())]+ default toDetail :: (Generic f, GToDetail (Rep f)) => f -> m [(Text, HtmlT m ())]+ toDetail x = do+ gToDetail (from x)+ -- case linkDetail x of+ -- Just p ->+ -- td_ [] $ a_ [href_ p] "detail"+ -- Nothing -> return ()+ linkDetail :: f -> m (Maybe PathText)+ linkDetail _ = return Nothing+ linkEdit :: f -> m (Maybe PathText)+ linkEdit _ = return Nothing+ detailTitle :: proxy f -> m Text+ default detailTitle :: (Generic f, GToDetail (Rep f)) => proxy f -> m Text+ detailTitle x = gDetailTitle (Proxy :: Proxy (Rep f))++class GToDetail (f :: * -> *) where+ gToDetail :: (MonadIO m, Monad m2) => f a -> m [(Text, HtmlT m2 ())]+ gDetailTitle :: (Monad m) => proxy f -> m Text++class Monad m => ToForm m a where+ toForm :: Maybe a -> m [(Text, HtmlT m ())]+ default toForm :: (Generic a, GToForm m (Rep a)) => Maybe a -> m [(Text, HtmlT m ())]+ toForm x = gToForm (from <$> x)+ fromForm :: [(ByteString, Maybe ByteString)] -> m (Either String a)+ default fromForm :: (Generic a, GToForm m (Rep a)) => [(ByteString, Maybe ByteString)] -> m (Either String a)+ fromForm x = fmap to <$> gFromForm x++class Monad m => GToForm m (f :: * -> *) where+ gToForm :: Maybe (f a) -> m [(Text, HtmlT m ())]+ gFromForm :: [(ByteString, Maybe ByteString)] -> m (Either String (f a))++class Monad m => FormField m a where+ toFormField :: Text -> Maybe a -> HtmlT m ()+ fromFormField :: [(ByteString, Maybe ByteString)] -> ByteString -> m (Maybe a)++-- todo: wrap [a]+class (HasHeader a, ToDetail m a, ToForm m b) => ListConsole m a b where+ list :: (Maybe b) -> Page -> m ([a])+ total :: Maybe b -> proxy a -> m (Maybe Int)+ total _ _ = pure Nothing+ listSublayout :: Maybe b -> [a] -> HtmlT m () -> HtmlT m ()+ listSublayout _ _ x = x+-- todo wrap a++class (ToDetail m a, Read (Ident a)) => DetailConsole m a where+ type Ident a+ detail :: Ident a -> m (Maybe a)+ detailSublayout :: a -> HtmlT m () -> HtmlT m ()+ detailSublayout _ x = x++-- class (ToForm m a, MonadIO m) => CreateConsole m a where+-- create :: a -> m ()+-- createPath :: proxy a -> m (PathText, PathText)++-- todo: edit, createを抽象化+-- editのみroute parameterを受け取っているのは間違い+-- note:+-- 小リソースの作成など、作成時に固定で使う値があるため、+-- 作成に使うデータbが、読み込むデータaのsubsetになっている。+-- ただし、aに値を設定する必要がない場合がほとんどであり、使いにくいかも（defで対応している）+-- フォームにできる時点で初期値を持てると言う意味かも+class (ToDetail m a, ToForm m b, Subtype b a) => CreateConsole m a b where+ create :: proxy a -> b -> m ()+ createdRedirectPath :: proxy a -> b -> m PathText+ -- createPath :: a -> proxy b -> m PathText+ detailForCreate :: Query -> proxy b -> m (Maybe a)+ createSublayout :: proxy b -> a -> HtmlT m () -> HtmlT m ()+ createSublayout _ _ x = x++class (ToDetail m a, ToForm m b, Read (EditIdent a b), Subtype b a) => EditConsole m a b where+ type EditIdent a b+ edit :: proxy a -> EditIdent a b -> b -> m () -- todo: use AllowAmbiguousTypes and TypeApplication?+ -- editPath :: proxy a -> proxy b -> EditIdent a b -> m (PathText, PathText)+ editedRedirectPath :: proxy a -> proxy b -> EditIdent a b -> m PathText+ detailForEdit :: proxy b -> EditIdent a b -> m (Maybe a)+ sublayout :: proxy b -> a -> HtmlT m () -> HtmlT m ()+ sublayout _ _ x = x+++class (Monad m, ToForm m a) => DeleteConsole m a where+ type DeleteIdent a+ delete :: DeleteIdent a -> a -> m ()+ deletedRedirectPath :: DeleteIdent a -> a -> m PathText++-- todo: /storeを対応、commentとかに変えて子コードにしてみる+-- todo: layout改善+-- todo: Console間のリンクを改善
+ src/TypedAdmin/Extra.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module TypedAdmin.Extra where++import Control.Monad+import Control.Monad.Trans.Class+import Data.ByteString.Lazy (toStrict)+import qualified Data.ByteString.UTF8 as BS+import Data.Default.Class+import Data.Maybe+import Data.Text (pack)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import GHC.Generics+import GHC.Int+import Lucid+import Text.Blaze.Renderer.Utf8 (renderMarkup)+import Text.Heterocephalus+import TypedAdmin.Class+import TypedAdmin.Instance ()+import TypedAdmin.Util++newtype Image = Image { unImage :: String }+ deriving (Show)++instance ToDetailField Image where+ toDetailField (Image x) = do+ a_ [href_ (pack x), target_ "_blank"] $+ img_ [src_ (pack x)]++newtype HiddenField a = HiddenField { unHiddenField :: a }+ deriving (Generic, Show)++instance Monad m => FormField m (HiddenField String) where+ toFormField n x = input_ [type_ "hidden", name_ n, value_ (pack $ fromMaybe "" $ unHiddenField <$> x)]+ fromFormField ps k = pure $ fmap HiddenField $ memptyToNothing =<< BS.toString <$> join (lookup k ps)++instance Monad m => FormField m (HiddenField Int64) where+ toFormField n x = input_ [type_ "text", name_ n, value_ (pack $ fromMaybe "" $ show . unHiddenField <$> x)]+ fromFormField ps k = pure $ fmap HiddenField $ lookupMaybe k ps++data Anchor a = Anchor a Text++instance ToDetailField a => ToDetailField (Anchor a) where+ toDetailField (Anchor x url) = do+ a_ [href_ url] $ toDetailField x++newtype TextArea = TextArea { unTextArea :: String }+ deriving (Show, Default)++instance Monad m => FormField m TextArea where+ toFormField n x = textarea_ [name_ n] $+ toHtml $ fromMaybe "" $ unTextArea <$> x+ fromFormField ps k = pure $ fmap TextArea $ memptyToNothing =<< BS.toString <$> join (lookup k ps)++newtype RangeField a = RangeField { unRangeField :: a }+ deriving (Show, Default)++instance (Monad m, Bounded a, Enum a) => FormField m (RangeField a) where+ toFormField n x = input_ [ type_ "range", name_ n+ , value_ (pack $ fromMaybe "" $ show . fromEnum . unRangeField <$> x)+ , step_ "1"+ , min_ (pack . show $ fromEnum (minBound :: a))+ , max_ (pack . show $ fromEnum (maxBound :: a))]+ fromFormField ps k = pure $ fmap (RangeField . toEnum) $ lookupMaybe k ps+++class GoogleApiEnv m where+ getKey :: m String++data GeoLocation = GeoLocation+ { lat :: Double+ , lon :: Double+ } deriving (Show, Generic)+instance Default GeoLocation++instance (Monad m, GoogleApiEnv m) => FormField m GeoLocation where+ toFormField n v = do+ let vlat = maybe "" (pack . show . lat) v+ input_ [type_ "text", id_ "locationLat", name_ (n <> "lat"), value_ vlat]+ let vlon = maybe "" (pack . show . lon) v+ input_ [type_ "text", id_ "locationLon", name_ (n <> "lon"), value_ vlon]+ div_ [id_ "map", style_ "height: 400px;"] ""+ script_ (decodeUtf8 $ toStrict $ renderMarkup $(compileTextFile "templates/javascript/map.js"))+ key <- lift $ getKey+ script_ [src_ ("https://maps.googleapis.com/maps/api/js?key=" <> pack key <> "&callback=initMap")] ("" :: String)+ -- async defer></script>+ fromFormField ps k = do+ lat <- fromFormField ps (k <> "lat")+ lon <- fromFormField ps (k <> "lon")+ return $ GeoLocation <$> lat <*> lon
+ src/TypedAdmin/Instance.hs view
@@ -0,0 +1,457 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module TypedAdmin.Instance where++import Control.Applicative+import Control.Monad+import Control.Monad.State.Class+import Control.Monad.Trans.Class+import qualified Data.ByteString.UTF8 as BS+import Data.Generics.Product.Subtype+import qualified Data.HashMap.Strict as M+import Data.Maybe+import Data.Proxy+import Data.Text as T (Text, dropWhile, pack)+import Data.Time+import Data.Yaml as Y+import GHC.Generics+import GHC.Int+import Lucid+import Network.HTTP.Types.URI (Query, renderQuery)+import TypedAdmin.Class+import TypedAdmin.Router+import TypedAdmin.Util++pushH :: MonadState Context m => Text -> m a -> m a+pushH k f = do+ modify (\x -> x { localeHierarchy = k:localeHierarchy x})+ r <- f+ modify (\x -> x { localeHierarchy = Prelude.tail (localeHierarchy x)})+ return r++toLocal :: MonadState Context m => Text -> m Text+toLocal k = do+ dic <- dic <$> get+ h <- localeHierarchy <$> get+ let k' = T.dropWhile (== '_') k+ let f d [] h k'' =+ case (M.lookup k'' =<< d, h) of+ (Just (Y.String x), _) -> return x+ (_, _:h') -> f dic h' h' k''+ (Just (Y.Object dic'), []) -> f (Just dic') [] [] "."+ (_, []) -> return (if k'' == "." then k' else k'')+ f d (h':hs) h k'' =+ case M.lookup h' =<< d of+ Just (Y.Object dic') -> f (Just dic') hs h k''+ _ -> f dic (tail h) (tail h) k''+ f dic h h k'++-- instance {-# OVERLAPS #-} (Show a) => ToHtml a where+-- toHtml = toHtml . show+-- toHtmlRaw = toHtmlRaw .show++-- instance ToHtml a => ToHtml (Maybe a) where+-- toHtml x = Data.Maybe.fromMaybe (toHtml ("" :: String)) $ toHtml <$> x+-- toHtmlRaw = toHtmlRaw++instance ToDetailField String where+ toDetailField x = span_ [] (toHtml x)++instance ToDetailField Bool where+ toDetailField x = span_ [] (toHtml (show x))++instance ToDetailField Integer where+ toDetailField x = span_ [] (toHtml (show x))+instance ToDetailField Int where+ toDetailField x = toDetailField (fromIntegral x :: Integer)+instance ToDetailField Int32 where+ toDetailField x = toDetailField (fromIntegral x :: Integer)+instance ToDetailField Int64 where+ toDetailField x = toDetailField (fromIntegral x :: Integer)++instance ToDetailField Day where+ toDetailField x = span_ [] (toHtml (show x))++instance ToDetailField UTCTime where+ toDetailField x = span_ [] (toHtml (show x))++instance ToDetailField LocalTime where+ toDetailField x = span_ [] (toHtml (show x))++instance ToDetailField a => ToDetailField (Maybe a) where+ toDetailField x = fromMaybe (span_ [] "")$ toDetailField <$> x++instance {-# OVERLAPPABLE #-} ToDetailField a => ToDetailField [a] where+ toDetailField xs = do+ ul_ [] $+ forM_ (toDetailField <$> xs) $ \x -> do+ li_ [] x++instance {-# OVERLAPPABLE #-} (Show a) => ToDetailField a where+ toDetailField x = span_ [] (toHtml $ show x)++-- instance GToDetail V1 where+-- gToDetail _ = error "toRow V1"++-- instance GToDetail U1 where+-- gToDetail _ = error "toRow U1"++instance (GToDetail f, GToDetail g) => GToDetail (f :*: g) where+ gToDetail (f :*: g) = do+ x <- gToDetail f+ y <- gToDetail g+ return $ x <> y+ gDetailTitle _ = pure "*"++-- instance (GToDetail f, GToDetail g) => GToDetail (f :+: g) where+-- gToDetail _ = error "toRow sum type"++instance (ToDetailField c, Selector s) => GToDetail (M1 S s (K1 i c)) where+ gToDetail x =+ let (M1 (K1 c)) = x+ in return [(pack (selName x), toDetailField c)]+ gDetailTitle _ = pure "--"++instance {-# OVERLAPPABLE #-} (GToDetail f, Constructor c) => GToDetail (M1 C c f) where+ gToDetail (M1 x) = do+ gToDetail x+ gDetailTitle x = pure $ pack $ conName (undefined :: M1 C c rep ())++instance {-# OVERLAPPABLE #-} (GToDetail f) => GToDetail (M1 i t f) where+ gToDetail (M1 x) = do+ gToDetail x+ gDetailTitle _ = gDetailTitle (Proxy :: Proxy f)+ -- gDetailTitle x = pure $ pack $ conName (undefined :: M1 C t f ())++-- instance {-# OVERLAPS #-} (ToDetail a, HasHeader a) => ToHtml [a] where+-- toHtml xs = do+-- table_ $ do+-- tr_ $ mapM_ th_ $ hasHeader (Proxy :: Proxy a)+-- forM_ xs $ (tr_ []) . toRow+-- toHtmlRaw = toHtml++-- instance GHasHeader V1 where+-- gHasHeader _ = error "hasHeader V1"++-- instance GHasHeader U1 where+-- gHasHeader _ = error "hasHeader U1"++instance (GHasHeader f, GHasHeader g) => GHasHeader (f :*: g) where+ gHasHeader _ = gHasHeader (Proxy :: Proxy f) ++ gHasHeader (Proxy :: Proxy g)++-- instance GHasHeader (f :+: g) where+-- gHasHeader _ = error "hasHeader sum type"++-- instance GHasHeader (K1 i c) where+-- gHasHeader (K1 x) = error "K1"++instance (Selector s) => GHasHeader (M1 S s k) where+ gHasHeader _ =+ [ do+ l <- lift $ toLocal $ pack $ selName (undefined :: t s k a)+ toHtml l+ ]+instance GHasHeader f => GHasHeader (M1 C t f) where+ gHasHeader _ = gHasHeader (Proxy :: Proxy f)++instance GHasHeader f => GHasHeader (M1 D t f) where+ gHasHeader _ = gHasHeader (Proxy :: Proxy f)++instance (GToForm m f, GToForm m g) => GToForm m (f :*: g) where+ gToForm (Just (f :*: g)) = do+ x <- gToForm (Just f)+ y <- gToForm (Just g)+ return $ x ++ y+ gToForm _ = do+ x <- gToForm (Nothing :: Maybe (f a))+ y <- gToForm (Nothing :: Maybe (g a))+ return $ x ++ y+ gFromForm ps = do+ x <- (gFromForm ps)+ y <- (gFromForm ps)+ pure $ liftA2 (:*:) x y++instance GToForm m f => GToForm m (M1 D t f) where+ gToForm (Just (M1 x)) = gToForm (Just x)+ gToForm _ = gToForm (Nothing :: Maybe (f a))+ gFromForm ps = do+ x <- gFromForm ps+ pure $ M1 <$> x++instance GToForm m f => GToForm m (M1 C t f) where+ gToForm (Just (M1 x)) = gToForm (Just x)+ gToForm _ = gToForm (Nothing :: Maybe (f a))+ gFromForm ps = do+ x <- gFromForm ps+ pure $ M1 <$> x++instance forall s m c i. (Selector s, FormField m c) => GToForm m (M1 S s (K1 i c)) where+ gToForm x = do+ let k = (\(M1 (K1 k)) -> k) <$> x+ sname = selName (undefined :: t s (K1 i (Maybe a)) p)+ pure [(pack sname, toFormField (pack $ sname) k)]+ gFromForm ps = do+ let sname = selName (undefined :: t s (K1 i (Maybe a)) p)+ mx <- fromFormField ps (BS.fromString $ sname)+ pure $ case mx of+ Just x -> Right $ M1 $ K1 x+ Nothing -> Left ("--GToForm--" <> show ps <> sname)++instance Monad m => FormField m String where+ toFormField n x = input_ [type_ "text", name_ n, value_ (pack $ fromMaybe "" x), required_ ""]+ fromFormField ps k = pure (BS.toString <$> join (lookup k ps))++instance {-# OVERLAPPING #-} Monad m => FormField m (Maybe String) where+ toFormField n x = input_ [type_ "text", name_ n, value_ (pack $ fromMaybe "" $ join x)+ , class_ "maybe"]+ fromFormField ps k =+ let x = BS.toString <$> join (lookup k ps)+ in pure $ Just $ memptyToNothing =<< x++instance Monad m => FormField m Bool where+ toFormField n x =+ let chkd = if (fromMaybe False x) then [checked_] else []+ in input_ $ [type_ "checkbox", name_ n] ++ chkd+ fromFormField ps k = pure $ Just $ isJust $ join (lookup k ps)++-- instance {-# OVERLAPS #-} (Integral a, Show a, Read a) => FormField a where+-- toFormField n x = input_ [type_ "number", name_ n, value_ (pack $ fromMaybe "" (show <$> x))]+-- fromFormField ps k = lookupMaybe k ps++toHtmlInput t n x = input_ [type_ t, name_ n, value_ (pack $ fromMaybe "" (show <$> x))]+fromHtmlInput ps k = pure $ lookupMaybe k ps++-- todo: Read,ShowなものはすべてtoTypeAttr実装し共通実装では？+instance Monad m => FormField m Int where+ toFormField = toHtmlInput "number"+ fromFormField = fromHtmlInput++instance Monad m => FormField m Int32 where+ toFormField = toHtmlInput "number"+ fromFormField = fromHtmlInput++instance Monad m => FormField m Int64 where+ toFormField = toHtmlInput "number"+ fromFormField = fromHtmlInput++instance Monad m => FormField m Double where+ toFormField = toHtmlInput "text"+ fromFormField = fromHtmlInput++instance Monad m => FormField m Day where+ toFormField = toHtmlInput "date"+ fromFormField = fromHtmlInput++instance FormField m a => FormField m (Maybe a) where+ toFormField n x = toFormField n (join x)+ fromFormField ps k = do+ x <- fromFormField ps k+ -- todo: Justが出てくる箇所多分型間違ってるので、見直す+ pure $ Just x++newtype SelectForm a = SelectForm { unSelectForm :: a}+ deriving (Show)+++selectFormField' :: forall a m.+ (Enum a, Bounded a, Show a, Read a, Monad m) =>+ Bool -> Text -> Maybe (SelectForm a) -> HtmlT m ()+selectFormField' required n x = do+ let min = minBound :: a+ max = maxBound :: a+ select_ [name_ n] $ do+ when (not required) $ option_ [value_ ""] ""+ forM_ [min .. max] $ \o -> do+ let sed = case x of+ Just (SelectForm x)+ | fromEnum o == fromEnum x -> [selected_ ""]+ | otherwise -> []+ _ -> []+ option_ ([value_ $ pack $ show $ fromEnum o] ++ sed) $ toHtml $ show o++fromSelectFormField ps k = pure $ fmap (SelectForm . toEnum) $ lookupMaybe k ps++instance {-# OVERLAPPING #-} (Enum a, Bounded a, Show a, Read a, Monad m) => FormField m (Maybe (SelectForm a)) where+ toFormField n x = selectFormField' False n (join x)+ fromFormField ps k = Just <$> fromSelectFormField ps k++instance (Enum a, Bounded a, Show a, Read a, Monad m) => FormField m (SelectForm a) where+ toFormField n x = selectFormField' True n x+ fromFormField = fromSelectFormField+++instance Monad m => ToForm m () where+ toForm _ = pure mempty+ fromForm _ = pure $ pure mempty++renderListHtml ::+ forall a b c d m . (Monad m, ListConsole m a b, PathParam c d, MonadState Context m)+ => [a]+ -> Maybe b+ -> (c, d, Query)+ -> (Int, Maybe Int)+ -> HtmlT m ()+renderListHtml xs p (path, param, query) (page, total) = do+ let pathText = toText $ renderPath path param+ -- liftIO $ print $ show (Proxy :: Proxy a)+ let hs = hasHeader (Proxy :: Proxy a)+ title <- lift $ detailTitle (Proxy :: Proxy a)+ title' <- toLocal title+ h1_ [] $ toHtml $ title'+ listSublayout p xs $ do+ pushH title $ do+ form_ [method_ "GET", action_ pathText, class_ "_typed_admin_search_form"] $ do+ form <- lift $ toForm p+ div_ [class_ "_typed_admin_fields"] $ do+ forM_ form $ \(name, fld) -> do+ div_ [] $ do+ dt_ [] $ do+ name' <- toLocal name+ label_ [] (toHtml name')+ dd_ [] $+ fld+ div_ [class_ "_typed_admin_actions"] $ do+ dt_ [] "action"+ dd_ [] $ do+ lblSearch <- toLocal "search"+ input_ [type_ "submit", value_ lblSearch]+ table_ [] $ do+ thead_ [] $+ tr_ $ mapM_ th_ hs+ tbody_ [] $ do+ forM_ xs $ \row -> do+ detail <- lift $ toDetail row+ tr_ [] $ do+ forM_ detail $ \(n, cell) -> do+ td_ [class_ ("_typed_admin_td_" <> n)] cell+ td_ [class_ "_typed_admin_actions"] $+ ul_ [] $ do+ editLbl <- toLocal "edit"+ forM_ [("detail", linkDetail), (editLbl, linkEdit)] $ \(l, g) -> do+ mp <- lift $ g row+ ll <- toLocal l+ whenJust mp $ \p -> li_ [] $ a_ [href_ p] $ toHtml ll+ -- forM_ (catMaybes+ -- [ (\u -> a_ [href_ u] "detail") <$> linkDetail row+ -- , (\u -> a_ [href_ u] "edit") <$> linkEdit row+ -- ]+ -- ) $ \a -> li_ [] a+ div_ [class_ "_typed_admin_pager"] $ do+ let rQuery q = pack (BS.toString (renderQuery True q))+ pageQ d = rQuery (setPageQuery (page + d) query)+ when (page > 0) $+ a_ [href_ (pathText <> pageQ (-1))] "prev"+ whenJust total $ \t ->+ forM_ [0..(t - 1)] $ \p -> do+ let sp = toHtml $ show (p + 1)+ if page == p+ then+ span_ $ sp+ else+ a_ [href_ (pathText <> rQuery (setPageQuery p query))] sp+ a_ [href_ (pathText <> pageQ 1)] "next"++setPageQuery page query =+ let p = ("page", Just $ BS.fromString $ show (page))+ in p:(filter ((/= "page") . fst) query)++renderDetailHtml :: forall a b m .+ (Monad m, DetailConsole m a, MonadState Context m)+ => a -> HtmlT m ()+renderDetailHtml x = do+ title <- lift $ detailTitle (Proxy :: Proxy a)+ title' <- toLocal title+ detail <- lift $ toDetail x+ div_ [class_ ("_typed_admin_detail_" <> title)] $ do+ h1_ [] $ toHtml $ title'+ detailSublayout x $ do+ pushH title $ do+ dl_ [] $ do+ forM_ detail $ \(name, field) -> do+ dt_ [] (toHtml name)+ dd_ [] field++toCreateForm :: forall a b c d proxy m .+ (Monad m, CreateConsole m a b, PathParam c d)+ => a+ -> proxy b+ -> (c, d)+ -> HtmlT m ()+toCreateForm x _ (path, param) = do+ detail <- lift $ toDetail x+ form <- lift $ toForm (Just (upcast x :: b))+ let pathText = toText $ renderPath path param+ let r =+ form_ [method_ "POST", action_ pathText] $ do+ dl_ $ do+ forM_ detail $ \(name, detailField) -> do+ dt_ [] $+ label_ [] (toHtml name)+ dd_ [] $+ fromMaybe (detailField) $ lookup name form+ tr_ $+ p_ [] "actions"+ dd_ $+ input_ [type_ "submit"]+ createSublayout (Proxy :: Proxy b) x r++renderEditHtml :: forall a b c d proxy m .+ (Monad m, EditConsole m a b, PathParam c d, MonadState Context m)+ => a+ -> proxy b+ -> EditIdent a b+ -> (c, d)+ -> HtmlT m ()+renderEditHtml x _ ident (path, param) = do+ title <- lift $ detailTitle (Proxy :: Proxy a)+ title' <- toLocal title+ div_ [class_ ("_typed_admin_detail_" <> title)] $ do+ h1_ [] $ toHtml $ title'+ detail <- lift $ toDetail x+ form <- lift $ toForm (Just (upcast x :: b))+ let pathText = toText $ renderPath path param+ sublayout (Proxy :: Proxy b) x $ do+ form_ [method_ "POST", action_ pathText] $ do+ dl_ $ do+ forM_ detail $ \(name, detailField) -> do+ dt_ [] $ do+ name' <- toLocal name+ label_ [] (toHtml name')+ dd_ [] $+ fromMaybe (detailField) $ lookup name form+ tr_ $ do+ lblActions <- toLocal "actions"+ p_ [] (toHtml lblActions)+ dd_ $+ input_ [type_ "submit"]++renderDeleteHtml :: forall a b c d proxy m .+ (Monad m, DeleteConsole m a, PathParam c d, MonadState Context m)+ => DeleteIdent a+ -> a+ -> (c, d)+ -> HtmlT m ()+renderDeleteHtml ident x (path, param) = do+ form <- lift $ toForm (Just x)+ let pathText = toText $ renderPath path param+ form_ [method_ "POST", action_ pathText] $ do+ forM_ form snd+ input_ [type_ "submit"]++-- instance (ToHtml c) => GToEditForm (K1 i c) where+-- gToEditForm (K1 x) = do+-- td_ (toHtml x)++-- instance (GToEditForm f) => GToEditForm (M1 i t f) where+-- gToEditForm (M1 x) = do+-- gToEditForm x+++-- todo: create router library, and refactor listPath andcreatePath, etc.
+ src/TypedAdmin/Router.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}++module TypedAdmin.Router where++import Control.Monad+import Data.String+import Data.Text (Text, intercalate, pack)+import Data.Typeable (Typeable)+import TypedAdmin.Class+import Web.HttpApiData++class PathParam a b where+ fromPath :: a -> [Text] -> Maybe b+ renderPath :: a -> b -> [Text]++instance PathParam (Path a) () where+ fromPath x y = f (Just Nothing) x y+ where+ f :: Maybe (Maybe ()) -> (Path b) -> [Text] -> Maybe ()+ f Nothing _ _ = Nothing+ f a EmptyP [] = join a+ f _ (StaticP p1 ps) (x:xs)+ | p1 == x = f (Just $ Just ()) ps xs+ | otherwise = Nothing+ f _ _ _ = Nothing+ renderPath path _ = f [] path+ where+ f :: [Text] -> (Path a) -> [Text]+ f xs EmptyP = xs+ f xs (StaticP p1 ps) = f (p1:xs) ps++toText = ("/" <>) . intercalate "/"++instance (FromHttpApiData a, ToHttpApiData a) => PathParam (Path '[a]) a where+ fromPath x y = f (Just Nothing) x y+ where+ f :: Maybe (Maybe a) -> (Path b) -> [Text] -> Maybe a+ f Nothing _ _ = Nothing+ f a EmptyP [] = join a+ f a (StaticP p1 ps) (x:xs)+ | p1 == x = f a ps xs+ | otherwise = Nothing+ f (Just Nothing) (VarP ps) (x:xs) = f (Just $ parseUrlPieceMaybe x) ps xs+ f _ _ _ = Nothing+ renderPath path x = f [] path+ where+ f :: [Text] -> (Path b) -> [Text]+ f xs EmptyP = xs+ f xs (StaticP p1 ps) = f (p1:xs) ps+ f xs (VarP ps) = f (toUrlPiece x:xs) ps++data Route m where+ ListR :: (ListConsole m a b) => Path c -> p1 a -> p2 b -> Route m+ DetailR :: (DetailConsole m a, PathParam (Path c) (Ident a)) => Path c -> p1 a -> Route m+ CreateR :: CreateConsole m a b => Path c -> p1 a -> p2 b -> Route m+ EditR :: (EditConsole m a b, PathParam (Path c) (EditIdent a b)) => Path c -> p1 a -> p2 b -> Route m+ DeleteR :: (DeleteConsole m a, PathParam (Path c) (DeleteIdent a)) => Path c -> p1 a -> Route m++instance a ~ '[] => IsString (Path a) where+ fromString x = StaticP (pack x) EmptyP++instance a ~ '[] => IsString (Path a -> Path a) where+ fromString x = StaticP (pack x)++data Path (as :: [*]) where+ EmptyP :: Path '[]+ StaticP :: Text -> Path as -> Path as+ VarP :: (FromHttpApiData a, Typeable a) => Path as -> Path (a ': as)+deriving instance Show (Path i)++static = StaticP++var :: (FromHttpApiData a, Typeable a) => Path as -> Path (a : as)+var = VarP++(</>) :: Path as -> (Path as -> Path bs) -> Path bs+(</>) x y = y x
+ src/TypedAdmin/Util.hs view
@@ -0,0 +1,20 @@+module TypedAdmin.Util where++import Control.Monad+import qualified Data.ByteString.UTF8 as BS+import Data.Maybe+import Text.Read++lookupMaybe k ps = readMaybe =<< BS.toString <$> join (lookup k ps)++whenJust (Just x) f = f x+whenJust _ _ = return ()++mapSnd f (x, y) = (x, f y)++memptyToNothing :: (Eq a, Monoid a) => a -> Maybe a+memptyToNothing x = if x == mempty then Nothing else Just x+++firstJust :: (a -> Maybe b) -> [a] -> Maybe b+firstJust f = listToMaybe . mapMaybe f
+ templates/javascript/map.js view
@@ -0,0 +1,24 @@+var map;+function initMap() {+ var textLocationLat = document.getElementById("locationLat")+ var textLocationLon = document.getElementById("locationLon")+ var initialLocation = {lat: parseFloat(textLocationLat.value),+ lng: parseFloat(textLocationLon.value)}+ map = new google.maps.Map(document.getElementById('map'), {+ center: initialLocation,+ zoom: 8+ });+ google.maps.event.addListener(map, 'click', function(event) {+ placeMarker(event.latLng);+ });+ var marker = new google.maps.Marker({+ position: initialLocation,+ map: map+ });+ function placeMarker(location) {+ console.log('location', location)+ marker.setPosition(location)+ textLocationLat.value = location.lat()+ textLocationLon.value = location.lng()+ }+}
+ typed-admin.cabal view
@@ -0,0 +1,127 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: d279f498e01236e4eeba599e54ec192a01d94bd39d0bf497afafcc0a6d3d4362++name: typed-admin+version: 0.1.0.0+synopsis: Admin console framework+description: Please see the README on GitHub at <https://github.com/nakaji-dayo/typed-admin#readme>+category: Web+homepage: https://github.com/nakaji-dayo/typed-admin#readme+bug-reports: https://github.com/nakaji-dayo/typed-admin/issues+author: Daishi Nakajima+maintainer: nakaji.dayo@gmail.com+copyright: 2018 Daishi Nakajima+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md+ templates/javascript/map.js++source-repository head+ type: git+ location: https://github.com/nakaji-dayo/typed-admin++flag example+ description: build example+ manual: True+ default: False++library+ exposed-modules:+ TypedAdmin+ TypedAdmin.Class+ TypedAdmin.Extra+ TypedAdmin.Instance+ TypedAdmin.Router+ TypedAdmin.Util+ other-modules:+ Paths_typed_admin+ hs-source-dirs:+ src+ build-depends:+ HDBC+ , HDBC-postgresql+ , HDBC-session+ , base >=4.7 && <5+ , blaze-markup+ , bytestring+ , data-default-class+ , exceptions+ , generic-lens >=1.1.0.0+ , heterocephalus+ , http-api-data+ , http-types+ , lucid+ , monad-control+ , mtl+ , persistable-record+ , relational-query+ , relational-query-HDBC+ , relational-record+ , template-haskell+ , text+ , time+ , transformers+ , transformers-base+ , unordered-containers+ , utf8-string+ , wai+ , wai-extra+ , warp+ , yaml+ default-language: Haskell2010++executable typed-admin-exe+ main-is: Main.hs+ other-modules:+ DataSource2+ Entity.Beer+ Entity.BeerImage+ Entity.Store+ Paths_typed_admin+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HDBC+ , HDBC-postgresql+ , HDBC-session+ , base >=4.7 && <5+ , blaze-markup+ , bytestring+ , data-default-class+ , exceptions+ , generic-lens >=1.1.0.0+ , heterocephalus+ , http-api-data+ , http-types+ , lens+ , lucid+ , monad-control+ , mtl+ , persistable-record+ , relational-query+ , relational-query-HDBC+ , relational-record+ , template-haskell+ , text+ , time+ , transformers+ , transformers-base+ , typed-admin+ , unordered-containers+ , utf8-string+ , wai+ , wai-extra+ , warp+ , yaml+ if !(flag(example))+ buildable: False+ default-language: Haskell2010