packages feed

tsweb (empty) → 0.1.0.0

raw patch · 17 files changed

+1632/−0 lines, 17 filesdep +Spockdep +Spock-coredep +basesetup-changed

Dependencies added: Spock, Spock-core, base, beam-core, beam-postgres, bytestring, http-api-data, hvect, postgresql-simple, pretty-simple, reroute, resource-pool, stm-containers, superrecord, tagged, text, time, transformers

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for spock-beam++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Jeremy Groven++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 Jeremy Groven 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,104 @@+# TsWeb - A very opinionated web API++TsWeb is a binding between the Spock web framework and the Beam database+API. It provides convenience functions for running database queries from+within Spock actions, a Spock session manager replacement using the Beam API,+and type-safe routing including type-checked reverse lookups (URLs are+associated with first-class labels which are used for reverse lookup).++## Sample Program++Most of the functionality of TsWeb (ideally, all of it) is demonstrated in the+example program, which lives under the Example directory of the source tree.+Have a look there for a working example of TsWeb.++## Restricted Views++TsWeb views run with minimal rights; by default they do not have access to the+database nor do they have any user information initialized. A view's type+signature enumerates its requirements, and those requirements are specified in+the view's routing. For example, a view that needs read-write database access,+an admin user, and a route to the index URL might have this type signature:++```+myview ::+  ( ListContains n0 Admin xs+  , ListContains n1 ReadWritePool xs+  , Has "index" lts (Path '[] 'Open) )+  => TsActionCtxT lts xs sessdata a+myview = do+  db :: ReadOnlyPool <- getExtra+  Admin me <- getExtra+  indexPath <- showPath #index+  ...+```++And then the view would be routed as:++```+runroute readonlypool readwritepool $+  path #index root (getpost indexView) .+  path #myview "mine" (dbwrite $ getpost $ auth adminP yview)+```++See the docs for "TsWeb.Routing" and "TsWeb.Routing.Auth" for more details.++## Action Queries++Have a look at "TsWeb.Db" for documentation on running Beam queries from a+Spock context. This is just sugar, but it's pretty nice. A small example:++```+myview :: ListContains n ReadWritePool xs => TsActionCtxT lts xs sessdata a+myview = do+  queryList (select $ all_ (_dbUser db)) >>= \case+    QSimply users -> text $ T.pack $ show users+    QError err -> text $ "Error: " <> Text.pack (show err)+```++See "TsWeb.Db" for more details.++## Session Manager++This is pretty much invisible, but use TsWeb.Session.patchConfig on your Spock+config to replace the default session manager with the TsWeb one. Lifted+directly from the "TsWeb.Session" documentation:++```+spockCfg <-+  patchConfig (_dbSession db) ropool rwpool <$>+  defaultSpockCfg sess PCNoDatabase ()+runSpock port (spock spockCfg routes)+where+  sess = ...+  routes = ...+```++## Type-safe URLs with reversing.++TsWeb builds on Spock's reroute library to also add type-checked reverse+lookups. There's a pretty complete document on that under "TsWeb.Routing",+which I'm simply pasting in here:++```+index :: Has "users" lts (Path '[] 'Open) => TsActionCtxT lts xs sess a+index = showPath #users >>= text++users :: Has "root" lts (Path '[] 'Open) => TsActionCtxT lts xs sess a+users = do+  root <- showPath #root+  text $ "GET users, root is, " <> root++usersPost :: TsActionCtxT lts xs sess a+usersPost = text "POST to users!"+```++Then, routing to those views looks like this:++```+runroute ropool rwpool $+  path #root root (getpost index) .+  path #users "users" (do get users+                          post usersPost)+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Example/Main.hs view
@@ -0,0 +1,51 @@+module Example.Main where++import Example.Types+import Example.Views++import TsWeb.Routing (dbwrite, get, getpost, path, post, runroute)+import TsWeb.Routing.Auth (auth)+import TsWeb.Session (patchConfig)+import TsWeb.Types (TsWebStateM)+import TsWeb.Types.Db (ReadOnlyPool, ReadWritePool, pool)++import qualified Web.Spock as Spock++import Web.Spock ((<//>), root, text, var)+import Web.Spock.Config (PoolOrConn(..), defaultSpockCfg, spc_csrfProtection)+import Web.Spock.Core (SpockCtxT)++main :: IO ()+main = do+  rwpool <- pool "localhost" "tsweb" "tsweb" 1 12 1+  ropool <- pool "localhost" "tsweb" "tsweb" 1 12 1+  spockCfg <-+    patchConfig (_dbSession db) ropool rwpool <$>+    defaultSpockCfg sess PCNoDatabase ()+  Spock.runSpock+    8080+    (Spock.spock (spockCfg {spc_csrfProtection = False}) (routes ropool rwpool))+  where+    sess :: SessionData+    sess = SessionData (UserId Nothing) False++routes ::+     ReadOnlyPool -> ReadWritePool -> SpockCtxT () (TsWebStateM SessionData) ()+routes ropool rwpool =+  runroute ropool rwpool $+  path+    #root+    root+    (do get index+        get $ auth userP userindex+        get $ auth adminP adminindex+        post $ text "post\n") .+  path #admin "admin" (get $ auth adminP adminindex) .+  path #users "users" (getpost users) .+  path+    #user+    ("users" <//> var)+    (do TsWeb.Routing.get $ viewuser+        dbwrite $ post makeuser) .+  path #login ("login" <//> var) (post login) .+  path #logind "login" (get loginstat) . path #logout "logout" (getpost logout)
+ src/Example/Types.hs view
@@ -0,0 +1,120 @@+module Example.Types where++import qualified TsWeb.Db++import TsWeb.Db (QueryResult(..), queryMaybe)+import TsWeb.Routing.Auth (Authorize(..))+import TsWeb.Session (UserData(..))+import TsWeb.Tables.Session (SessionT)++import qualified Data.Text as Text+import qualified Web.Spock as Spock++import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Database.Beam++data Db f = Db+  { _dbUser :: f (TableEntity UserT)+  , _dbSession :: f (TableEntity (SessionT SessionDataT))+  } deriving (Generic)++instance Database be Db++db :: DatabaseSettings be Db+db = defaultDbSettings++data UserT f = User+  { _userId :: C f Int+  , _userLogin :: C f Text+  } deriving (Generic)++type User = UserT Identity++type UserId = PrimaryKey UserT Identity++data SessionDataT f = SessionData+  { _sdUser :: PrimaryKey UserT (Nullable f)+  , _sdRemember :: C f Bool+  } deriving (Generic)++type SessionData = SessionDataT Identity++data Admin =+  Admin User+  deriving (Eq, Ord, Show)++adminP :: Proxy Admin+adminP = Proxy++instance Authorize SessionData Admin where+  checkAuth _ =+    _sdUser <$> Spock.readSession >>= \case+      UserId Nothing -> pure Nothing+      UserId (Just uid) ->+        queryMaybe (select $ q uid) >>= \case+          QSimply (Just user) ->+            if "-admin" `Text.isSuffixOf` _userLogin user+              then pure $ Just (Admin user)+              else pure Nothing+          _ -> pure Nothing+    where+      q uid = do+        u <- all_ $ _dbUser db+        guard_ $ _userId u ==. val_ uid+        pure u++userP :: Proxy User+userP = Proxy++instance Authorize SessionData User where+  checkAuth _ =+    _sdUser <$> Spock.readSession >>= \case+      UserId Nothing -> pure Nothing+      UserId (Just uid) ->+        queryMaybe (select $ q uid) >>= \case+          QSimply (Just user) -> pure $ Just user+          _ -> pure Nothing+    where+      q uid = do+        u <- all_ $ _dbUser db+        guard_ $ _userId u ==. val_ uid+        pure u++deriving instance Show (PrimaryKey UserT (Nullable Identity))++deriving instance Show (PrimaryKey UserT Identity)++deriving instance Show User++deriving instance Eq (PrimaryKey UserT (Nullable Identity))++deriving instance Eq (PrimaryKey UserT Identity)++deriving instance Eq User++deriving instance Ord (PrimaryKey UserT (Nullable Identity))++deriving instance Ord (PrimaryKey UserT Identity)++deriving instance Ord User++instance Beamable (PrimaryKey UserT)++instance Beamable UserT++instance Table UserT where+  data PrimaryKey UserT f = UserId (Columnar f Int)+                            deriving Generic+  primaryKey = UserId . _userId++deriving instance Show SessionData++deriving instance Eq SessionData++deriving instance Ord SessionData++instance Beamable SessionDataT++instance UserData SessionData where+  rememberMe = _sdRemember
+ src/Example/Views.hs view
@@ -0,0 +1,114 @@+module Example.Views where++import Example.Types++import TsWeb.Action (getExtra, getPath, showPath)+import TsWeb.Db (QueryResult(..), TxOpt(..), execute, queryList, queryMaybe)+import TsWeb.Types (TsActionCtxT)+import TsWeb.Types.Db (ReadOnlyPool, ReadWritePool)++import qualified Data.Text as Text+import Database.Beam as Beam+import qualified Web.Spock as Spock++import Data.HVect (ListContains)+import Data.Monoid ((<>))+import Data.Text (Text)+import Database.Beam ((==.), all_, default_, guard_, just_, nothing_, pk, val_)+import SuperRecord (Has)+import Web.Routing.Combinators (PathState(Open))+import Web.Spock (Path, text)++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"++userindex ::+     ( ListContains n User xs+     , Has "users" lts (Path '[] 'Open)+     , Has "user" lts (Path '[ Text] 'Open)+     )+  => TsActionCtxT lts xs SessionData a+userindex = do+  (u :: User) <- getExtra+  p0 <- showPath #users+  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 = do+  p <- getPath #users+  text $ Spock.renderRoute p <> "\n"++users :: ListContains n ReadOnlyPool xs => TsActionCtxT lts xs SessionData a+users =+  queryList (Beam.select $ all_ (_dbUser db)) >>= \case+    QSimply lst ->+      text $+      "Users: " <> Text.intercalate ", " [_userLogin u | u <- lst] <> "\n"+    QError err -> text $ "Error: " <> Text.pack (show err)++viewuser ::+     ListContains n ReadOnlyPool xs => Text -> TsActionCtxT lts xs SessionData a+viewuser user =+  queryMaybe (Beam.select q) >>= \case+    QError err -> text $ "Error: " <> Text.pack (show err)+    QSimply Nothing -> text $ "User " <> user <> " not found\n"+    QSimply (Just u) -> text $ (Text.pack $ show u) <> "\n"+  where+    q = do+      u <- all_ $ _dbUser db+      guard_ $ _userLogin u ==. val_ user+      pure u++makeuser ::+     ListContains n ReadWritePool xs+  => Text+  -> TsActionCtxT lts xs SessionData a+makeuser user = do+  res <-+    execute NoTx $+    Beam.runInsert $+    Beam.insert (_dbUser db) $+    Beam.insertExpressions [User default_ (val_ user)]+  text $ (Text.pack $ show res) <> "\n"++login ::+     ListContains n ReadOnlyPool xs => Text -> TsActionCtxT lts xs SessionData a+login user =+  queryMaybe (Beam.select q) >>= \case+    QError err -> text $ "Error: " <> Text.pack (show err)+    QSimply Nothing -> text $ "User " <> user <> " not found\n"+    QSimply (Just u) -> do+      sess <- Spock.readSession+      Spock.writeSession $ sess {_sdUser = just_ $ pk u}+      text $ (Text.pack $ show u) <> "\n"+  where+    q = do+      u <- all_ $ _dbUser db+      guard_ $ _userLogin u ==. val_ user+      pure u++loginstat :: ListContains n ReadOnlyPool xs => TsActionCtxT lts xs SessionData a+loginstat = do+  sess <- Spock.readSession+  case _sdUser sess of+    (UserId Nothing) -> text "Not logged in\n"+    (UserId (Just uid)) ->+      queryMaybe (Beam.select $ q uid) >>= \case+        QSimply Nothing -> text "Logged in as a non-existent user!?\n"+        QSimply (Just u) -> text $ "Logged in as " <> _userLogin u <> "\n"+        QError err -> text $ "Error: " <> Text.pack (show err) <> "\n"+  where+    q uid = do+      u <- all_ $ _dbUser db+      guard_ $ _userId u ==. val_ uid+      pure u++logout :: TsActionCtxT lts xs SessionData a+logout = do+  sess <- Spock.readSession+  Spock.writeSession $ sess {_sdUser = nothing_}+  text "Logged Out\n"
+ src/TsWeb/Action.hs view
@@ -0,0 +1,83 @@+{-|+Description: Spock actions for interacting with the 'TsWeb.Types.Context'++Various functions for reading data from the current Spock Action's context.+Currently that's just reading URL path info and auth data.+-}+module TsWeb.Action+  ( getPath+  , showPath+  , getExtra+  ) where++import TsWeb.Types (Context(..), TsActionCtxT)++import Data.HVect (AllHave, HVectElim, ListContains, findFirst)+import Data.Text (Text)+import Database.Beam hiding (runSelectReturningList, runSelectReturningOne)+import SuperRecord (FldProxy, Has, get)+import Web.HttpApiData (ToHttpApiData)+import Web.Routing.Combinators (PathState(Open))+import Web.Spock (ActionCtxT, Path, getContext, renderRoute)++-- | Look up a tagged path in a view. If we have a route looking like+--+-- @+--   'TsWeb.Routing.runroute' ro rw $ 'TsWeb.Routing.path' #user ("users" \<//\> var) ('TsWeb.Routing.get' user)+-- @+--+-- then a view could access that user path with+--+-- @+--   users <- getPath #user+--   let txt = 'Web.Spock.renderRoute' users "bob"+-- @+getPath :: (Has l lts v) => FldProxy l -> TsActionCtxT lts xs sess v+getPath tag = SuperRecord.get tag . ctxPaths <$> getContext++-- | Look up a path and render it. This returns a sort-of variadic function+-- that can be provided with the right number of arguments in order to render+-- a path. As with the above example, a route like this:+--+-- @+--   'TsWeb.Routing.runroute' ro rw $ 'TsWeb.Routing.path' #user ("users" \<//\> var) ('TsWeb.Routing.get' user)+-- @+--+-- could be rendered like this:+--+-- @+--   usersfn <- showPath #user+--   let txt = usersfn "bob"+-- @+--+-- or, more succinctly:+--+-- @+--   txt <- ($ "bob") \<$\> showPath $user+-- @+showPath ::+     (AllHave ToHttpApiData as, Has l lts v, v ~ Path as 'Open)+  => FldProxy l+  -> TsActionCtxT lts vec sess (Data.HVect.HVectElim as Text)+showPath tag = do+  path <- getPath tag+  pure $ renderRoute path++-- | Look up data that was put into the 'ctxExtras' part of the action's+-- context. This is pretty bound up with type signatures and other verbosity,+-- but if we have a database-writing view like so:+--+-- @+--   'TsWeb.Routing.runroute' ro rw $ 'TsWeb.Routing.path' #root 'Web.Spock.root' ('TsWeb.Routing.dbwrite' $ 'TsWeb.Routing.get' index)+-- @+--+-- then that index view could be written like so:+--+-- @+--   index :: 'Data.HVect.ListContains' n 'TsWeb.Types.Db.ReadWritePool' xs => 'TsActionCtxT' lts xs sess a+--   index = do+--     db :: ReadWritePool <- getExtra+--     ...+-- @+getExtra :: (MonadIO m, ListContains n v xs) => ActionCtxT (Context lts xs) m v+getExtra = findFirst . ctxExtras <$> getContext
+ src/TsWeb/Db.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-}+{-|+Description: Beam actions for Spock++This builds on "TsWeb.Types.Db"'s read-only/read-write discrimination by+providing query functions to perform read-only operations, and an 'execute'+function to run updates, inserts, and deletes (and also selects as+appropriate). All of these are performed as 'TsWeb.Types.TsActionCtxT' actions+so as to nicely integrate with Spock. Finally, because I'm not a fan of+exceptions, all of these functions trap Postgres errors and convert them into+sum-type results.++I'm not yet providing shortcuts for the beam-postgres specific functions. I'm+not actually sure that I need to (IIRC they all build Pg actions), but I will+be adding them if necessary.+-}++module TsWeb.Db+  ( module Database.Beam+  , TxOpt(..)+  , QueryResult(..)+  , ExecResult(..)+  , runSelectReturningList+  , runSelectReturningOne+  , query+  , queryMaybe+  , queryList+  , execute+  ) where++import qualified TsWeb.Types.Db as Db++import TsWeb.Action (getExtra)+import TsWeb.Types (TsActionCtxT)+import TsWeb.Types.Db (ReadOnlyPool, ReadWritePool)++import qualified Database.Beam as Beam++import Control.Exception (catch, try)+import Data.HVect (ListContains)+import Database.Beam hiding (runSelectReturningList, runSelectReturningOne)+import Database.Beam.Postgres (Pg, Postgres)+import Database.PostgreSQL.Simple (SqlError(..))+import Database.PostgreSQL.Simple.Errors+  ( ConstraintViolation(..)+  , constraintViolationE+  )++#if MIN_VERSION_beam_core(0, 8, 0)+type Sel a = SqlSelect Postgres a+#else+import Database.Beam.Postgres (PgSelectSyntax)+type Sel a = SqlSelect PgSelectSyntax a+#endif++class ReadOnlyM m where+  runSelectReturningOne ::+       FromBackendRow Postgres a => Sel a -> m (Maybe a)+  runSelectReturningList ::+       FromBackendRow Postgres a => Sel a -> m [a]++instance ReadOnlyM Pg where+  runSelectReturningOne = Beam.runSelectReturningOne+  runSelectReturningList = Beam.runSelectReturningList++newtype RoPg a = RoPg+  { _fromRoPg :: Pg a+  } deriving (Functor, Applicative, Monad)++instance ReadOnlyM RoPg where+  runSelectReturningOne = RoPg . Beam.runSelectReturningOne+  runSelectReturningList = RoPg . Beam.runSelectReturningList++-- | Transaction option: provide WithTx to wrap operations in BEGIN/COMMIT, or+-- NoTx to skip that.+data TxOpt+  = NoTx+  | WithTx+  deriving (Eq, Ord, Enum, Bounded, Show)++-- | Result of a select operation. This will either succeed with a QSimply, or+-- fail with a QError (probably then an error in the db connection or table+-- definitions).+data QueryResult a+  = QSimply a+  | QError SqlError+  deriving (Eq, Show)++-- | Run one or many Beam 'Database.Beam.runSelectReturningList' or+-- 'Database.Beam.runSelectReturningOne' operation(s) against a view's+-- ReadOnlyPool.+query ::+     ListContains n ReadOnlyPool xs+  => TxOpt+  -> RoPg a+  -> TsActionCtxT lts xs sessdata (QueryResult a)+query opt (RoPg act) = do+  ropool :: ReadOnlyPool <- getExtra+  liftIO $ catch (QSimply <$> Db.withConnection ropool io) (pure . QError)+  where+    io conn =+      case opt of+        NoTx -> Db.readOnly conn act+        WithTx -> Db.withTransaction conn $ Db.readOnly conn act++-- | Run a single Beam 'select', returning a single (Maybe) value+queryMaybe ::+     (ListContains n ReadOnlyPool xs, FromBackendRow Postgres a)+  => Sel a+  -> TsActionCtxT lts xs sessdata (QueryResult (Maybe a))+queryMaybe = query NoTx . runSelectReturningOne++-- | Run a single Beam 'select', returning a list of values+queryList ::+     (ListContains n ReadOnlyPool xs, FromBackendRow Postgres a)+  => Sel a+  -> TsActionCtxT lts xs sessdata (QueryResult [a])+queryList = query NoTx . runSelectReturningList++-- | The result of a select, insert, update, or delete operation. This adds a+-- constraint error to the 'QueryResult', making it nicer to filter out+-- conflicts when handling errors.+data ExecResult a+  = ESimply a+  | EConstraint SqlError+                ConstraintViolation+  | EError SqlError+  deriving (Eq, Show)++-- | Run any arbitrary 'Database.Beam.Pg' monad in the context of a view,+-- returning an 'ExecResult'+execute ::+     ListContains n ReadWritePool xs+  => TxOpt+  -> Pg a+  -> TsActionCtxT lts xs sessdata (ExecResult a)+execute opt act = do+  rwpool <- getExtra+  liftIO $ handleError rwpool+  where+    handleError rwpool =+      try (Db.withConnection rwpool io) >>= \case+        Right a -> return $ ESimply a+        Left err ->+          case constraintViolationE err of+            Nothing -> return $ EError err+            Just (s, c) -> return $ EConstraint s c+    io conn =+      case opt of+        NoTx -> Db.readWrite conn act+        WithTx -> Db.withTransaction conn $ Db.readWrite conn act
+ src/TsWeb/Routing.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE ExplicitNamespaces #-}++{-|+Description: Tagged routes for Spock++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+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:++First, we'll define a couple of views:++@+  index :: Has "users" lts (Path '[] 'Open) => TsActionCtxT lts xs sess a+  index = 'TsWeb.Actions.showPath' #users >>= 'Spock.text++  users :: Has "root" lts (Path '[] 'Open) => TsActionCtxT lts xs sess a+  users = do+    root <- 'TsWeb.Actions.showPath' #root+    text $ "GET users, root is, " \<\> root++  usersPost :: TsActionCtxT lts xs sess a+  usersPost = text "POST to users!"+@++Then, routing to those views looks like this:++@+  'runroute' ropool rwpool $+    'path' #root 'Web.Spock.root' ('getpost' index) .+    'path' #users "users" (do get users+                              post usersPost)+@++Notice the (.) after the @getpost index@. We're chaining functions together+and then passing that chained function to 'runroute' in order to generate an+actual Spock 'Web.Spock.Routing.RouteM'.+-}+module TsWeb.Routing+  ( RoutingM+  , runroute+  , path+  , dbwrite+  , getpost+  , get+  , post+  ) where++import TsWeb.Types (Context(..), TsActionCtxT, TsSpockCtxT)+import TsWeb.Types.Db (ReadOnlyPool, ReadWritePool)++import qualified SuperRecord as SR+import qualified Web.Spock as Spock+import qualified Web.Spock.Routing++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT(..), ask, mapReaderT)+import Data.HVect (HVect(..), HVectElim, HasRep)+import GHC.TypeLits (type (-), KnownNat, KnownSymbol)+import SuperRecord ((:=)(..), FldProxy, Rec, Record, Sort, (&), rnil)+import Web.Routing.Combinators (PathState(Open))+import Web.Spock (Path)+import Web.Spock.Routing (withPrehook)++-- | Reader monad to pass one 'Web.Spock.Path' to potentially multiple+-- different 'get'/'post'/etc calls.+type RoutingM as lts xs sess+   = ReaderT (Path as 'Open, ReadWritePool) (TsSpockCtxT lts xs sess)++-- | Convert a chain of 'path' calls into a 'Web.Spock.Routing.RouteM'+-- instance. This takes a 'TsWeb.Types.Db.ReadOnlyPool' and a+-- 'TsWeb.Types.Db.ReadWritePool' in order to operate the+-- 'TsWeb.Routing.Auth.auth' and 'dbwrite' calls.+runroute ::+     (Applicative f, MonadIO m, Web.Spock.Routing.RouteM t)+  => ReadOnlyPool  -- ^Read-only postgres connection pool+  -> ReadWritePool -- ^Read-write postgres connection pool+  -> ((ReadWritePool, Rec '[], f ()) -> ( ReadWritePool+                                        , Rec lts+                                        , t (Context lts '[ ReadOnlyPool]) m ()))+  -- ^Chain of functions built up using 'path' calls+  -> t ctx m ()+runroute ropool rwpool fn =+  let (_p, r, m) = fn (rwpool, rnil, pure ())+   in Spock.prehook (pure $ Context r (ropool :&: HNil)) m++-- | Describe a path for routing. This both builds up the+-- 'Web.Spock.Routing.RouteM' monad and associates the given label with the+-- URL so that views can look up the URL using 'TsWeb.Action.showPath' &c.+path ::+     ( KnownNat ((SR.RecSize (Sort (l := (Path as 'Open) : lts)) - SR.RecTyIdxH 0 l (Sort (l := (Path as 'Open) : lts))) - 1)+     , SR.RecCopy lts lts (Sort (l := (Path as 'Open) : lts))+     , KnownNat (SR.RecSize lts)+     , SR.KeyDoesNotExist l lts+     , KnownSymbol l+     )+  => FldProxy l                 -- ^Label for this URL path+  -> (Path as 'Open)            -- ^'Web.Spock.Path' for views+  -> RoutingM as lts0 xs sess a+  -- ^Routing monad built from 'get' \/ 'post' \/ &c+  -> (ReadWritePool, Rec lts, (TsSpockCtxT lts0 xs sess) a)+  -- ^Result of previous 'path' call, or initial data from 'runroute'+  -> ( ReadWritePool+     , Record (l := (Path as 'Open) : lts)+     , (TsSpockCtxT lts0 xs sess) a)+path l t m (pool, r, m0) = (pool, l := t & r, m0 >> runReaderT m (t, pool))++-- | Raise up a 'RoutingM' to have 'TsWeb.Types.Db.ReadWritePool' in its+-- extras record.+dbwrite ::+     RoutingM as lts (ReadWritePool ': xs) sess () -> RoutingM as lts xs sess ()+dbwrite action = do+  (_path, pool) <- ask+  xform pool action+  where+    xform ::+         nn -> RoutingM as lts (nn ': xs) sess () -> RoutingM as lts xs sess ()+    xform nn = mapReaderT (xform' nn)+    xform' ::+         nn -> TsSpockCtxT lts (nn ': xs) sess () -> TsSpockCtxT lts xs sess ()+    xform' nn = withPrehook (xform'' nn)+    xform'' :: nn -> TsActionCtxT lts xs sess (Context lts (nn ': xs))+    xform'' nn = do+      ctx <- Spock.getContext+      pure $ ctx {ctxExtras = nn :&: ctxExtras ctx}++-- | Run this view whether the client did a GET or a POST request+getpost ::+     Data.HVect.HasRep as+  => Data.HVect.HVectElim as (TsActionCtxT lts xs sess ())+  -> RoutingM as lts xs sess ()+getpost action = do+  (p, _) <- ask+  lift $ Spock.getpost p action++-- | Run this view only on GET requests+get ::+     Data.HVect.HasRep as+  => Data.HVect.HVectElim as (TsActionCtxT lts xs sess ())+  -> RoutingM as lts xs sess ()+get action = do+  (p, _) <- ask+  lift $ Spock.get p action++-- | Run this view only on POST requests+post ::+     Data.HVect.HasRep as+  => Data.HVect.HVectElim as (TsActionCtxT lts xs sess ())+  -> RoutingM as lts xs sess ()+post action = do+  (p, _) <- ask+  lift $ Spock.post p action
+ src/TsWeb/Routing/Auth.hs view
@@ -0,0 +1,100 @@+{-|+Description: Auth hook for routing++A generic authentication hook for TsWeb routing. The goal here is to be able+to specify authentication requirements in a view's type, so that the routing+statically guarantees that a view can only be entered when session+preconditions are met. A full example of this is under the Example module of+this source tree, but a synopsis follows. Given a session/user definition like+so:++@+  data UserT f = User+    { _userId :: C f Int+    , _userLogin :: C f Text+    } deriving (Generic)+  ...+  data SessionDataT f = SessionData+    { _sdUser :: PrimaryKey UserT (Nullable f)+    , _sdRemember :: C f Bool+    } deriving (Generic)+  ...++  userP :: 'Data.Proxy.Proxy' User+  userP = Proxy+@++then we can define a logged-in 'Authorize' check as++@+instance Authorize SessionData User where+  checkAuth _ =+    _sdUser \<$\> 'Web.Spock.readSession' >>= \case+      UserId Nothing -> pure Nothing+      UserId (Just uid) ->+        'TsWeb.Db.queryMaybe' ('Database.Beam.select' $ q uid) >>= \case+          QSimply (Just user) -> pure $ Just user+          _ -> pure Nothing+    where+      q uid = do+        u <- 'Database.Beam.all_' $ _dbUser db+        'Database.Beam.guard_' $ _userId u ==. 'Database.Beam.val_' uid+        pure u+@++A view requiring an authenticated user would have a signature like++@+  authd :: ListContains n User xs => TsActionCtxT lts xs SessionData a+  authd = do+    user :: User <- 'TsWeb.Action.getExtra'+    ...+@++Finally, the route for only allowing logged-in users would look like++@+  'TsWeb.Routing.runroute' ro rw $ 'TsWeb.Routing.path' #authd "authd" $ `TsWeb.Routing.get' $ 'auth' userP authd+@++That view is statically defined to only be accessible to logged-in users; any+anonymous session will either go to an alternate (non-auth) view, or get a+404.+-}+module TsWeb.Routing.Auth where++import TsWeb.Types (Context(..), TsActionCtxT)+import TsWeb.Types.Db (ReadOnlyPool)++import Data.HVect (HVect((:&:)), ListContains)+import Data.Proxy (Proxy)+import Web.Spock (getContext)+import Web.Spock.Action (jumpNext, runInContext)++-- | A class for session data that needs to be statically verified against+-- routes. This could be checks for optional session info, or to validate the+-- value of that session information.+class Authorize sess perm where+  -- | Load a value out of the session or return Nothing. Used in the context+  -- of 'auth', the wrapped view will only be called when this returns Just; a+  -- Nothing value will cause the wrapped view to be skipped.+  checkAuth ::+       ListContains n ReadOnlyPool xs+    => Proxy perm+    -> TsActionCtxT lts xs sess (Maybe perm)++-- | Guarantee that the Spock session hold some verified piece of data. If the+-- requisite data can be loaded, then the view is called with the data in its+-- ctxExtras; otherwise 'Web.Spock.Action.jumpNext' is called and the view is+-- skipped.+auth ::+     (Authorize sess perm, ListContains n ReadOnlyPool xs, Authorize sess perm)+  => Proxy perm+  -> TsActionCtxT lts (perm ': xs) sess ()+  -> TsActionCtxT lts xs sess ()+auth proxy action =+  checkAuth proxy >>= \case+    Nothing -> jumpNext+    Just a -> do+      ctx <- getContext+      runInContext (ctx {ctxExtras = a :&: ctxExtras ctx}) action
+ src/TsWeb/Session.hs view
@@ -0,0 +1,309 @@+{-|+Description: Spock Session implementation for Beam++This provides one essential function, 'patchConfig' to replace Spock's default+in-RAM session implementation with a Beam/postgres one.+-}+module TsWeb.Session+  ( patchConfig+  , UserData(..)+  ) where++import qualified TsWeb.Tables.Session as T+import qualified TsWeb.Types.Db as Db++import TsWeb.Tables.Session (SessionT(..))+import TsWeb.Types.Db (ReadOnlyConn, ReadWriteConn, SomeConn)++import qualified Database.Beam as Beam++import Control.Monad (unless)+import Data.Maybe (fromJust)+import Data.Pool (Pool)+import Data.Time.Format (buildTime, defaultTimeLocale)+import Database.Beam ((==.), all_, guard_, val_)+import Database.Beam.Backend.SQL.SQL92 (HasSqlValueSyntax)+import Database.Beam.Postgres (Postgres)+import Database.Beam.Postgres.Syntax (PgValueSyntax)+import Database.Beam.Schema.Tables (FieldsFulfillConstraint)+import Web.Spock.Config+  ( SessionStore(..)+  , SessionStoreInstance(..)+  , SpockCfg(..)+  , sc_store+  )+import Web.Spock.Internal.SessionManager as SM (Session(..), SessionId)++data TxAction s next+  = LoadSession SM.SessionId+                (Maybe s -> next)+  | DeleteSession SM.SessionId+                  next+  | StoreSession s+                 next+  | ToList ([s] -> next)+  | FilterSessions (s -> Bool)+                   next++type TxProgram s = Free (TxAction s)++-- | Update a spock configuration stanza to replace its default session with+-- one backed by postgres.  This will typically be used like so:+--+-- @+--  spockCfg <-+--    'patchConfig' (_dbSession db) ropool rwpool <$>+--    'Web.Spock.Config.defaultSpockCfg' sess PCNoDatabase ()+--  'Web.Spock.runSpock' port ('Web.Spock.spock' spockCfg routes)+--  where+--    sess = ...+--    routes = ...+-- @+--+patchConfig ::+     ( Beam.FromBackendRow Postgres (sessdata Beam.Identity)+     , Beam.Beamable sessdata+     , Beam.Typeable sessdata+     , Beam.Database Postgres db+     , UserData (sessdata Beam.Identity)+     , FieldsFulfillConstraint (HasSqlValueSyntax PgValueSyntax) sessdata+     )+  => Beam.DatabaseEntity Postgres db (Beam.TableEntity (SessionT sessdata))+  -> Pool ReadOnlyConn+  -> Pool ReadWriteConn+  -> SpockCfg conn (sessdata Beam.Identity) st+  -> SpockCfg conn (sessdata Beam.Identity) st+patchConfig session ropool rwpool conf = conf {spc_sessionCfg = updSession}+  where+    updSession = sessCfg {sc_store = customStore}+    sessCfg = spc_sessionCfg conf+    customStore = SessionStoreInstance $ newPgSessionStore session ropool rwpool++-- | Typeclass for user-supplied data. We really just need to know whether the+-- user has set a remember-me indicator upon login so that the session's+-- lifespan can be intelligently controlled. If your session never needs to be+-- remembers, then @rememberMe = const False@ should suffice.+class UserData c where+  -- | Should the associated session be stored permanently?+  rememberMe :: c -> Bool++newPgSessionStore ::+     ( Beam.FromBackendRow Postgres (sessdata Beam.Identity)+     , Beam.Beamable sessdata+     , Beam.Typeable sessdata+     , Beam.Database Postgres db+     , UserData (sessdata Beam.Identity)+     , FieldsFulfillConstraint (HasSqlValueSyntax PgValueSyntax) sessdata+     )+  => Beam.DatabaseEntity Postgres db (Beam.TableEntity (SessionT sessdata))+  -> Pool ReadOnlyConn+  -> Pool ReadWriteConn+  -> SessionStore (SM.Session conn (sessdata Beam.Identity) st) (TxProgram (SM.Session conn (sessdata Beam.Identity) st))+newPgSessionStore session ropool rwpool =+  SessionStore+    { ss_runTx = runTxProgram session ropool rwpool+    , ss_loadSession = liftF . flip LoadSession id+    , ss_deleteSession = liftF . flip DeleteSession ()+    , ss_storeSession = liftF . flip StoreSession ()+    , ss_toList = liftF $ ToList id+    , ss_filterSessions =+        \fn -> do+          ss <- liftF $ ToList id+          mapM_ (\s -> unless (fn s) (liftF $ DeleteSession (sess_id s) ())) ss+    , ss_mapSessions =+        \fn -> do+          ss <- liftF $ ToList id+          mapM_+            (\s -> do+               s' <- fn s+               liftF $ StoreSession s' ())+            ss+    }++loadSession' ::+     ( Beam.FromBackendRow Postgres (sessdata Beam.Identity)+     , Beam.Beamable sessdata+     , Beam.Typeable sessdata+     , Beam.Database Postgres db+     )+  => Beam.DatabaseEntity Postgres db (Beam.TableEntity (SessionT sessdata))+  -> SomeConn c+  -> SM.SessionId+  -> IO (Maybe (SM.Session conn (sessdata Beam.Identity) st))+loadSession' session conn sessionid = do+  match <-+    Db.readOnly conn $+    Beam.runSelectReturningOne $+    Beam.select $ do+      sess <- all_ session+      guard_ (_sessionId sess ==. val_ sessionid)+      pure sess+  case match of+    Nothing -> return Nothing+    Just result ->+      return $+      Just+        (SM.Session+           (_sessionId result)+           (_sessionCsrf result)+           (_sessionExpires result)+           (_sessionData result))++deleteSession' ::+     Beam.DatabaseEntity Postgres db (Beam.TableEntity (SessionT sessdata))+  -> ReadWriteConn+  -> SM.SessionId+  -> IO ()+deleteSession' session conn sessionid =+  Db.readWrite conn $+  Beam.runDelete $+  Beam.delete session (\sess -> _sessionId sess ==. val_ sessionid)++storeSession' ::+     ( Beam.FromBackendRow Postgres (sessdata Beam.Identity)+     , Beam.Beamable sessdata+     , Beam.Typeable sessdata+     , Beam.Database Postgres db+     , UserData (sessdata Beam.Identity)+     , FieldsFulfillConstraint (HasSqlValueSyntax PgValueSyntax) sessdata+     )+  => Beam.DatabaseEntity Postgres db (Beam.TableEntity (SessionT sessdata))+  -> ReadWriteConn+  -> SM.Session conn (sessdata Beam.Identity) st+  -> IO ()+storeSession' session conn sess = Db.readWrite conn go+  where+    go =+      getSess >>= \case+        Nothing ->+          Beam.runInsert $+          Beam.insert session $+          Beam.insertExpressions+            [ T.Session+                (val_ $ sess_id sess)+                (val_ $ sess_csrfToken sess)+                (val_ $+                 if rememberMe (sess_data sess)+                   then farOut+                   else sess_validUntil sess)+                (val_ $ sess_data sess)+            ]+        Just exist ->+          Beam.runUpdate $+          Beam.save+            session+            (exist+               { _sessionCsrf = sess_csrfToken sess+               , _sessionExpires =+                   if rememberMe (sess_data sess)+                     then farOut+                     else sess_validUntil sess+               , _sessionData = sess_data sess+               })+    getSess =+      Beam.runSelectReturningOne $+      Beam.lookup_ session (T.SessionId $ sess_id sess)+    farOut = fromJust $ buildTime defaultTimeLocale [('Y', "2999")]++toList' ::+     ( Beam.FromBackendRow Postgres (sessdata Beam.Identity)+     , Beam.Beamable sessdata+     , Beam.Typeable sessdata+     , Beam.Database Postgres db+     )+  => Beam.DatabaseEntity Postgres db (Beam.TableEntity (SessionT sessdata))+  -> SomeConn a+  -> IO [SM.Session conn (sessdata Beam.Identity) st]+toList' session conn = do+  sessions <- go+  return $+    [ SM.Session+      (_sessionId s)+      (_sessionCsrf s)+      (_sessionExpires s)+      (_sessionData s)+    | s <- sessions+    ]+  where+    go =+      Db.readOnly conn $+      Beam.runSelectReturningList $ Beam.select $ all_ session++instance Functor (TxAction s) where+  fmap f (LoadSession sessid g) = LoadSession sessid (f . g)+  fmap f (DeleteSession sessid x) = DeleteSession sessid (f x)+  fmap f (StoreSession sess x) = StoreSession sess (f x)+  fmap f (ToList g) = ToList (f . g)+  fmap f (FilterSessions g x) = FilterSessions g (f x)++data Free f r+  = Free (f (Free f r))+  | Pure r++instance Functor f => Functor (Free f) where+  fmap f = go+    where+      go (Pure a) = Pure (f a)+      go (Free fa) = Free (go <$> fa)++instance (Functor f) => Applicative (Free f) where+  pure = Pure+  Pure a <*> Pure b = Pure $ a b+  Pure a <*> Free mb = Free $ fmap a <$> mb+  Free ma <*> b = Free $ (<*> b) <$> ma++instance (Functor f) => Monad (Free f) where+  return = Pure+  (Free x) >>= f = Free (fmap (>>= f) x)+  (Pure r) >>= f = f r++instance Show sessdata => Show (TxProgram (SM.Session conn sessdata st) a) where+  show = show'+    where+      show' (Free (LoadSession sid g)) =+        "Load " ++ (show sid) ++ " / " ++ show' (g Nothing)+      show' (Free (DeleteSession sid g)) =+        "Delete " ++ (show sid) ++ " / " ++ show' g+      show' (Free (StoreSession sid g)) =+        "Store " ++ (show $ sess_id sid) ++ " / " ++ show' g+      show' (Free (ToList g)) = "ToList / " ++ show' (g [])+      show' (Free (FilterSessions _ g)) = "Filter / " ++ show' g+      show' (Pure _) = "Pure"++runTxProgram ::+     ( Beam.FromBackendRow Postgres (sessdata Beam.Identity)+     , Beam.Beamable sessdata+     , Beam.Typeable sessdata+     , Beam.Database Postgres db+     , UserData (sessdata Beam.Identity)+     , FieldsFulfillConstraint (HasSqlValueSyntax PgValueSyntax) sessdata+     )+  => Beam.DatabaseEntity Postgres db (Beam.TableEntity (SessionT sessdata))+  -> Db.ReadOnlyPool+  -> Db.ReadWritePool+  -> TxProgram (SM.Session conn (sessdata Beam.Identity) st) a+  -> IO a+runTxProgram session ropool rwpool tx =+  (Db.withConnection ropool $ \conn -> ro conn tx) >>= \case+    Just res -> return res {- putStrLn "Ran read-only query" >> -}+    Nothing {- do+      putStrLn "Running read-write query" -}+     -> Db.withConnection rwpool $ flip rw tx+  where+    ro conn (Free (LoadSession sessid g)) =+      loadSession' session conn sessid >>= ro conn . g+    ro conn (Free (ToList g)) = toList' session conn >>= ro conn . g+    ro _conn (Pure p) = pure $ Just p+    ro _conn _free = pure Nothing+    rw conn (Free (LoadSession sessid g)) =+      loadSession' session conn sessid >>= rw conn . g+    rw conn (Free (DeleteSession sessid g)) =+      deleteSession' session conn sessid >> rw conn g+    rw conn (Free (StoreSession sess g)) =+      storeSession' session conn sess >> rw conn g+    rw conn (Free (ToList g)) = toList' session conn >>= rw conn . g+    rw conn (Free (FilterSessions _b n)) = rw conn n+    rw _conn (Pure p) = pure p++liftF :: Functor f => f r -> Free f r+liftF x = Free (fmap Pure x)
+ src/TsWeb/Tables/Session.hs view
@@ -0,0 +1,45 @@+{-|+Description: Beam table definition for a generic Spock session++Spock likes to store its session RAM, which is mostly great unless you need+persistence or multiple machines. This doesn't do anything interesting with+Spock's session manager, but just defines enough of a table to be able to+store Spock's core session information.+-}+module TsWeb.Tables.Session where++import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import Database.Beam++-- | A generic Beam table to store a Spock session. The '_sessionData' should+-- be your useful info, like a logged-in user or whatever. See+-- "TsWeb.Tables.Session.Test" for a type-checking but not very function idea+-- of what '_sessionData' could look like, or the code under+-- 'Example.Main.main' for a fully-functional (but dumb) webapp using all this+-- stuff.+data SessionT d f = Session+  { _sessionId :: C f Text          -- ^Spock-generated session ID+  , _sessionCsrf :: C f Text        -- ^Session's CSRF token+  , _sessionExpires :: C f UTCTime  -- ^Expiration date for this session+  , _sessionData :: d f             -- ^User-defined session data+  } deriving (Generic)++-- |Concrete session+type Session d = SessionT d Identity++-- |Session primary key+type SessionId d = PrimaryKey (SessionT d) Identity++deriving instance Show (PrimaryKey (SessionT d) Identity)+deriving instance Show (d Identity) => Show (Session d)+deriving instance Eq (PrimaryKey (SessionT d) Identity)+deriving instance Eq (d Identity) => Eq (Session d)+deriving instance Ord (PrimaryKey (SessionT d) Identity)+deriving instance Ord (d Identity) => Ord (Session d)+instance Beamable (PrimaryKey (SessionT d))+instance Beamable d => Beamable (SessionT d)+instance (Beamable d, Typeable d) => Table (SessionT d) where+  data PrimaryKey (SessionT d) f = SessionId (Columnar f Text)+                                   deriving Generic+  primaryKey = SessionId . _sessionId
+ src/TsWeb/Tables/Session/Test.hs view
@@ -0,0 +1,50 @@+{-|+Description: Test module to be sure the generic 'Session' is sane+-}+module TsWeb.Tables.Session.Test where++import TsWeb.Session+import TsWeb.Tables.Session++import Data.Pool (Pool)+import Database.Beam+import TsWeb.Types.Db (ReadOnlyConn, ReadWriteConn)+import Web.Spock.Config+import Web.Spock.Internal.SessionManager as SM (Session(..))++-- | Some sample user info+data UsersMixin f = Address+  { loginid :: C f Int+  , masqid :: C f Int+  , remember :: C f Bool+  } deriving (Generic)++-- | Concrete type for users+type Users = UsersMixin Identity++instance Beamable UsersMixin+instance UserData Users where+  rememberMe = remember++-- | Spock session alias to use our User+type Sess conn st = SM.Session conn Users st++-- | Beam database definition to hold our session+data Db f = Db+  { session :: f (TableEntity (SessionT UsersMixin))+  } deriving (Generic)++instance Database be Db++-- | Beam database instance+db :: DatabaseSettings be Db+db = defaultDbSettings++-- | Sample of patch to be sure that all the types work enough to make a spock+-- config wrapper+patch ::+     Pool ReadOnlyConn+  -> Pool ReadWriteConn+  -> SpockCfg conn Users st+  -> SpockCfg conn Users st+patch = patchConfig (session db)
+ src/TsWeb/Types.hs view
@@ -0,0 +1,39 @@+{-|+Description: Web types for TsWeb++These are the base wrappers around Spock's contexts and state monad. The main+thing that TsWeb does is force in a 'Context' type that is a wrapper around a+'SuperRecord.Rec' and a 'Data.HVect.HVect'. The Rec is used to store tagged+URL paths, while the HVect stores contextual data for views, such as a+database connection or authentication information.+-}+module TsWeb.Types where++import Data.HVect (HVect)+import SuperRecord (Rec)+import Web.Spock (ActionCtxT, WebStateM)+import Web.Spock.Core (SpockCtxT)++-- | A container for a 'SuperRecord.Rec' of tagged Spock paths and a+-- `Data.HVect.HVect' of view contextual data.+--+-- The paths are built with 'TsWeb.Routing.path' and friends, and are queried+-- using `TsWeb.Action.getPath' / 'TsWeb.Action.showPath'.+--+-- Context extras are currently populated using 'TsWeb.Routing.dbwrite' and+-- 'TsWeb.Routing.Auth.auth'; probably more will be added as needed.+data Context lts vec = Context+  { ctxPaths :: Rec lts    -- ^Tagged paths for web context+  , ctxExtras :: HVect vec -- ^Free-form extras for web context+  }++-- | Wrapper around 'WebStateM' to suppress spock's database and web_state+type TsWebStateM sessdata = WebStateM () sessdata ()++-- | Wrapper around 'ActionCtxT' to use 'Context' and 'TsWebStateM'+type TsActionCtxT lts xs sessdata a+   = ActionCtxT (Context lts xs) (TsWebStateM sessdata) a++-- | Wrapper around 'SpockCtxT' to use 'Context' and 'TsWebStateM'+type TsSpockCtxT lts xs sessdata+   = SpockCtxT (Context lts xs) (TsWebStateM sessdata)
+ src/TsWeb/Types/Db.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE CPP #-}+{-|+Description: Database-specific types and core functions++TsWeb has a strong notion that postgres should be configured in a warm-standby+mode, with read-only queries being shipped to synchronous standbys whenever+possible. This module defines types for descriminating between read-only and+read-write connections, and also functions for making postgres connections,+pools, etc. The 'connect' function is working well enough for me, but will+undoubtedly need to be improved to support the full depth of postgresql+connection options.+-}+module TsWeb.Types.Db+  ( SomeConn+  , ReadOnlyConn+  , ReadWriteConn+  , ReadOnlyPool+  , ReadWritePool+  , ReadOnly+  , ReadWrite+  , HostName+  , DbName+  , SubPools+  , KeepOpen+  , count+  , pool+  , withConnection+  , connect+  , withSavepoint+  , withTransaction+  , readOnly+  , readOnlyDebug+  , readWrite+  , readWriteDebug+  ) where++import qualified Database.Beam.Postgres as PG+import qualified Database.PostgreSQL.Simple as Simple++import Data.Pool (Pool, createPool, withResource)+import Data.Tagged (Tagged(..))+import Data.Time.Clock (NominalDiffTime)+import Database.Beam hiding (runSelectReturningList, runSelectReturningOne)+import Database.Beam.Postgres+  ( Connection+  , Pg+  , runBeamPostgres+  , runBeamPostgresDebug+  )+import qualified Database.Beam.Query.Internal as BI++#if MIN_VERSION_beam_core(0, 8, 0)+import Database.Beam.Postgres (Postgres)+#else+import Database.Beam.Postgres.Syntax (PgExpressionSyntax, PgSelectSyntax)+#endif++-- | An example of how @Database.Beam@ does counts; this really doesn't belong+-- here, and was just written for preliminary testing.+#if MIN_VERSION_beam_core(0, 8, 0)+count ::+     (BI.ProjectibleWithPredicate BI.AnyType Postgres (BI.WithExprContext+           (BI.BeamSqlBackendExpressionSyntax' Postgres)) t)+  => Q Postgres db (BI.QNested s0) t+  -> Q Postgres db s0 (QGenExpr QValueContext Postgres s0 Int)+#else+count ::+     BI.ProjectibleWithPredicate BI.AnyType PgExpressionSyntax t+  => Q PgSelectSyntax db (BI.QNested s0) t+  -> Q PgSelectSyntax db s0 (QGenExpr QValueContext PgExpressionSyntax s0 Int)+#endif+count = aggregate_ (const countAll_)++-- | Empty type to mark read-only db connections+data ReadOnly++-- | Empty type to mark read-write db connections+data ReadWrite++-- | Wrapper for some sort of Postgres connection; a raw `SomeConn t`+-- represents either a read-only or a read-write connection, but the concrete+-- `ReadOnlyConn` and `ReadWriteConn` are probably more useful in general.+type SomeConn t = Tagged t Connection++-- | Concrete read-only connection. Instantiate with 'connect'+type ReadOnlyConn = SomeConn ReadOnly++-- | Concrete read-write connection. Instantiate with 'connect'+type ReadWriteConn = SomeConn ReadWrite++-- | Pool of read-only connections. Instantiate with 'pool'+type ReadOnlyPool = Pool ReadOnlyConn++-- | Pool of read-write connections. Instantiate with 'pool'+type ReadWritePool = Pool ReadWriteConn++-- | String alias for the postgres host to connect to+type HostName = String++-- | String alias for the postgres database to connect to+type DbName = String++-- | Int alias for the 'Data.Pool.createPool' function @numStripes@ argument+type SubPools = Int++-- | Int alias for the 'Data.Pool.createPool' function @maxResources@ argument+type KeepOpen = Int++-- | Create a resource pool of either read-only or read-write postgres+-- connections. The docs for `Data.Pool.createPool' give the best description+-- for how this works.+pool ::+     HostName        -- ^Postgres hostname/address+  -> DbName          -- ^Postgres database name+  -> String          -- ^User to connect as+  -> SubPools        -- ^Number of sub-pools to maintain (1 is fine)+  -> NominalDiffTime -- ^How long to let an idle db connection linger+  -> KeepOpen        -- ^Max number of connections per stripe+  -> IO (Pool (SomeConn t))+pool host db username =+  createPool (connect host db username) (PG.close . unTagged)++-- | Run an action in a 'Pool' connection+withConnection :: Pool (SomeConn a) -> (SomeConn a -> IO b) -> IO b+withConnection = withResource++-- | Create a 'ReadOnly' or 'ReadWrite' postgres connection. This doesn't+-- actually check whether the connection is read-only or read-write, so it's+-- really just to help with type juggling.+connect :: HostName -> DbName -> String -> IO (SomeConn t)+connect host db username =+  print db >>+  Tagged <$>+  (PG.connect $+   PG.defaultConnectInfo+     {PG.connectUser = username, PG.connectDatabase = db, PG.connectHost = host})++-- | Run an action within a postgresql savepoint+withSavepoint :: SomeConn t -> IO a -> IO a+withSavepoint (Tagged c) = Simple.withSavepoint c++-- | Run an action within a postgresql transaction+withTransaction :: SomeConn t -> IO a -> IO a+withTransaction (Tagged c) = Simple.withTransaction c++-- | Run a read-only query; this will actually run any query at all, so+-- higher-level logic should ensure that only read-only queries hit this+-- function.+readOnly :: SomeConn t -> Pg a -> IO a+readOnly (Tagged conn) = runBeamPostgres conn++-- | Same as 'readOnly', but prints any SQL that it runs.+readOnlyDebug :: SomeConn t -> Pg a -> IO a+readOnlyDebug (Tagged conn) = runBeamPostgresDebug putStrLn conn++-- | Run a query against a ReadWriteConn+readWrite :: ReadWriteConn -> Pg a -> IO a+readWrite (Tagged conn) = runBeamPostgres conn++-- | Same as 'readWrite', but printing all the SQL that gets executed.+readWriteDebug :: ReadWriteConn -> Pg a -> IO a+readWriteDebug (Tagged conn) = runBeamPostgresDebug putStrLn conn
+ tsweb.cabal view
@@ -0,0 +1,113 @@+-- Initial tsweb.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                tsweb+version:             0.1.0.0+synopsis:            An API binding Web.Spock to Database.Beam+-- description:         +license:             BSD3+license-file:        LICENSE+author:              Jeremy Groven+maintainer:          jeremy.groven@gmail.com+-- copyright:           +category:            Web+build-type:          Simple+extra-source-files:  ChangeLog.md+                   , README.md+cabal-version:       >=1.10++library+  exposed-modules:     TsWeb.Action+                     , TsWeb.Db+                     , TsWeb.Routing.Auth+                     , TsWeb.Routing+                     , TsWeb.Session+                     , TsWeb.Tables.Session+                     , TsWeb.Tables.Session.Test+                     , TsWeb.Types.Db+                     , TsWeb.Types+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=4.9 && <4.13+                     , beam-core >=0.7 && <0.9+                     , beam-postgres >=0.3 && <0.5+                     , bytestring+                     , http-api-data+                     , hvect+                     , postgresql-simple+                     , pretty-simple+                     , reroute+                     , resource-pool+                     , Spock >= 0.13 && < 0.14+                     , Spock-core >= 0.13 && < 0.14+                     , stm-containers >= 0.2 && < 0.3+                     , superrecord >= 0.5 && < 0.6+                     , tagged+                     , text+                     , time+                     , transformers+  hs-source-dirs:      src+  default-extensions:  ConstraintKinds+                     , DeriveGeneric+                     , DataKinds+                     , FlexibleContexts+                     , FlexibleInstances +                     , LambdaCase+                     , MultiParamTypeClasses+                     , OverloadedLabels+                     , OverloadedStrings+                     , ScopedTypeVariables+                     , StandaloneDeriving+                     , TypeApplications+                     , TypeFamilies +                     , TypeOperators+  default-language:    Haskell2010+  ghc-options:         -Wall++executable example+  main-is: Example/Main.hs+  other-modules:       Example.Types+                     , Example.Views+                     , TsWeb.Action+                     , TsWeb.Db+                     , TsWeb.Routing+                     , TsWeb.Routing.Auth+                     , TsWeb.Session+                     , TsWeb.Tables.Session+                     , TsWeb.Types+                     , TsWeb.Types.Db+  build-depends:       base >=4.9 && <4.13+                     , beam-core >=0.7 && <0.9+                     , beam-postgres >=0.3 && <0.5+                     , bytestring+                     , http-api-data+                     , hvect+                     , postgresql-simple+                     , pretty-simple+                     , reroute+                     , resource-pool+                     , Spock >= 0.13 && < 0.14+                     , Spock-core >= 0.13 && < 0.14+                     , stm-containers >= 0.2 && < 0.3+                     , superrecord >= 0.5 && < 0.6+                     , tagged+                     , text+                     , time+                     , transformers+  hs-source-dirs:      src+  default-extensions:  ConstraintKinds+                     , DeriveGeneric+                     , DataKinds+                     , FlexibleContexts+                     , FlexibleInstances +                     , LambdaCase+                     , MultiParamTypeClasses+                     , OverloadedLabels+                     , OverloadedStrings+                     , ScopedTypeVariables+                     , StandaloneDeriving+                     , TypeApplications+                     , TypeFamilies +                     , TypeOperators+  default-language:    Haskell2010+  ghc-options:         -Wall -main-is Example.Main.main