tsweb 0.1.0.0 → 0.1.1
raw patch · 6 files changed
+89/−8 lines, 6 filesdep +claydep +cryptonite
Dependencies added: clay, cryptonite
Files
- README.md +1/−1
- src/Example/Main.hs +2/−0
- src/Example/Views.hs +24/−5
- src/TsWeb/Routing.hs +1/−1
- src/TsWeb/Routing/Clay.hs +54/−0
- tsweb.cabal +7/−1
README.md view
@@ -87,7 +87,7 @@ users :: Has "root" lts (Path '[] 'Open) => TsActionCtxT lts xs sess a users = do root <- showPath #root- text $ "GET users, root is, " <> root+ text $ "GET users, root is, " \<\> root usersPost :: TsActionCtxT lts xs sess a usersPost = text "POST to users!"
src/Example/Main.hs view
@@ -5,6 +5,7 @@ import TsWeb.Routing (dbwrite, get, getpost, path, post, runroute) import TsWeb.Routing.Auth (auth)+import TsWeb.Routing.Clay (clay) import TsWeb.Session (patchConfig) import TsWeb.Types (TsWebStateM) import TsWeb.Types.Db (ReadOnlyPool, ReadWritePool, pool)@@ -33,6 +34,7 @@ ReadOnlyPool -> ReadWritePool -> SpockCtxT () (TsWebStateM SessionData) () routes ropool rwpool = runroute ropool rwpool $+ clay #css "css" style . path #root root
src/Example/Views.hs view
@@ -7,10 +7,12 @@ import TsWeb.Types (TsActionCtxT) import TsWeb.Types.Db (ReadOnlyPool, ReadWritePool) +import qualified Clay as Clay import qualified Data.Text as Text-import Database.Beam as Beam+import qualified Database.Beam as Beam import qualified Web.Spock as Spock +import Clay (Css, (?), (|>), px) import Data.HVect (ListContains) import Data.Monoid ((<>)) import Data.Text (Text)@@ -22,8 +24,7 @@ adminindex :: (ListContains n Admin xs, Has "users" lts (Path '[] 'Open)) => TsActionCtxT lts xs SessionData a-adminindex =- showPath #users >>= \u -> text $ "Hello admin!\n" <> u <> "\n"+adminindex = showPath #users >>= \u -> text $ "Hello admin!\n" <> u <> "\n" userindex :: ( ListContains n User xs@@ -37,10 +38,13 @@ p1 <- ($ _userLogin u) <$> showPath #user text $ "Hello " <> _userLogin u <> "!\n" <> p0 <> "\n" <> p1 <> "\n" -index :: Has "users" lts (Path '[] 'Open) => TsActionCtxT lts xs SessionData a+index ::+ (Has "css" lts (Path '[] 'Open), Has "users" lts (Path '[] 'Open))+ => TsActionCtxT lts xs SessionData a index = do p <- getPath #users- text $ Spock.renderRoute p <> "\n"+ c <- getPath #css+ text $ Spock.renderRoute p <> "\n" <> Spock.renderRoute c <> "\n" users :: ListContains n ReadOnlyPool xs => TsActionCtxT lts xs SessionData a users =@@ -112,3 +116,18 @@ sess <- Spock.readSession Spock.writeSession $ sess {_sdUser = nothing_} text "Logged Out\n"++style :: Css+style = do+ Clay.header |> Clay.nav ? do+ Clay.background Clay.white+ Clay.color "#04a"+ Clay.fontSize (px 24)+ Clay.padding 20 0 20 (px 0)+ Clay.textTransform Clay.uppercase+ Clay.position Clay.absolute+ Clay.left (px 0)+ Clay.right (px 0)+ Clay.bottom (px (-72))+ ".foo" ?+ Clay.background Clay.grey
src/TsWeb/Routing.hs view
@@ -5,7 +5,7 @@ This module builds on Spock's "reroute" library by associating a "GHC.OverloadedLabels" label to each route, which views can then use to-reverse routes in a type-safe manner. It also uses some rediculous function+reverse routes in a type-safe manner. It also uses some ridiculous function chaining to almost create an indexed monad, but not quite because I can't figure out quite how to make that work. A fairly function example follows:
+ src/TsWeb/Routing/Clay.hs view
@@ -0,0 +1,54 @@+{-|+Description: Clay CSS helper++This defines a helper function, 'clay', which will serve a 'Clay.Css' instance+from a labeled URL prefix.+-}+module TsWeb.Routing.Clay+ ( clay+ ) where++import qualified TsWeb.Routing as R++import TsWeb.Types (TsSpockCtxT)+import TsWeb.Types.Db (ReadWritePool)++import qualified SuperRecord as SR+import qualified Web.Spock as Spock++import Clay (Css, pretty, renderWith) -- compact)+import Crypto.Hash (Blake2b_160, Digest, hash)+import Data.Monoid ((<>))+import Data.Text.Encoding (encodeUtf8)+import Data.Text.Lazy (toStrict)+import GHC.TypeLits (type (-), KnownNat, KnownSymbol)+import SuperRecord ((:=)(..), FldProxy, Rec, Record, Sort)+import Web.Routing.Combinators (PathState(Open))+import Web.Spock (Path, (<//>))++-- | Serve a 'Clay.Css' instance. The rendered CSS will be served from a .css+-- file whose name is derived from the rendered sheet's contents. This has two+-- results: changing the stylesheet will change the sheet's full URL, and the+-- stylesheet really needs to be referenced by label, using something like+-- `TsWeb.Action.showPath'. The first one of those is actually really nice,+-- since browsers are so aggressive about caching css. The second one is more+-- convenient anyhow, so this function is just pretty nice.+clay ::+ ( SR.KeyDoesNotExist l lts+ , SR.RecCopy lts lts (Sort (l := (Path '[] 'Open) : lts))+ , KnownNat (SR.RecSize lts)+ , (KnownNat ((SR.RecSize (Sort (l := Path '[] 'Open : lts)) - SR.RecTyIdxH 0 l (Sort (l := Path '[] 'Open : lts))) - 1))+ , KnownSymbol l+ )+ => FldProxy l -- ^Label to access this stylesheet+ -> String -- ^Base URL for this sheet+ -> Css -- ^'Clay.Css' instance to serve+ -> (ReadWritePool, Rec lts, TsSpockCtxT lts0 xs sess ())+ -> ( ReadWritePool+ , Record (l := (Path '[] 'Open) : lts)+ , TsSpockCtxT lts0 xs sess ())+clay l base css =+ let sheet = toStrict $ renderWith pretty [] css <> "\n"+ dgst = hash (encodeUtf8 sheet) :: Digest Blake2b_160+ url = Spock.static base <//> Spock.static (show dgst ++ ".css")+ in R.path l url (R.get $ Spock.text sheet)
tsweb.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: tsweb-version: 0.1.0.0+version: 0.1.1 synopsis: An API binding Web.Spock to Database.Beam -- description: license: BSD3@@ -20,6 +20,7 @@ exposed-modules: TsWeb.Action , TsWeb.Db , TsWeb.Routing.Auth+ , TsWeb.Routing.Clay , TsWeb.Routing , TsWeb.Session , TsWeb.Tables.Session@@ -32,6 +33,8 @@ , beam-core >=0.7 && <0.9 , beam-postgres >=0.3 && <0.5 , bytestring+ , clay+ , cryptonite , http-api-data , hvect , postgresql-simple@@ -72,6 +75,7 @@ , TsWeb.Db , TsWeb.Routing , TsWeb.Routing.Auth+ , TsWeb.Routing.Clay , TsWeb.Session , TsWeb.Tables.Session , TsWeb.Types@@ -80,6 +84,8 @@ , beam-core >=0.7 && <0.9 , beam-postgres >=0.3 && <0.5 , bytestring+ , clay+ , cryptonite , http-api-data , hvect , postgresql-simple