scottish (empty) → 0.1.0.0
raw patch · 7 files changed
+345/−0 lines, 7 filesdep +basedep +data-defaultdep +http-typessetup-changed
Dependencies added: base, data-default, http-types, lens, mtl, persistent, resource-pool, scotty, stm, text, transformers, wai, warp
Files
- LICENSE +30/−0
- README.md +4/−0
- Setup.hs +2/−0
- scottish.cabal +67/−0
- src/Web/Scottish.hs +180/−0
- src/Web/Scottish/Database.hs +45/−0
- src/Web/Scottish/Database/Persist.hs +17/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014 Zhang Yichao++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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,4 @@+# Scottish++Provides global read-only configuration and global/action-local read-write+states to [Scotty](https://github.com/scotty-web/scotty).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ scottish.cabal view
@@ -0,0 +1,67 @@+name: scottish+version: 0.1.0.0+synopsis: scotty with batteries included+description:+ Scotty web framework with batteries included. For configurations/states, you+ don't need to hand-roll your own monads every time. Scottish will manage it+ for you.+ .+ @+ {-# LANGUAGE OverloadedStrings #-}+ .+ import Web.Scottish+ .+ import Data.Monoid (mconcat)+ import Data.Monoid (mconcat)+ import Data.Text.Lazy (Text)+ import Network.HTTP.Types.Status (notFound404)+ .+ main = scottish' 3000 $ do+   setConfig (Just "beam")+ .+   get "/" $ do+     beam <- getConfig :: ScottishActionM' (Maybe Text) () (Maybe Text)+     html $ mconcat ["<h1>Scotty, ", fromJust beam, " me up!</h1>"]+ .+   get "/:word" $ do+     raise notFound404+ @+ .+ [Scotty] <http://hackage.haskell.org/package/scotty>++homepage: https://github.com/echaozh/scottish+bug-reports: https://github.com/echaozh/scottish/issues+license: BSD3+license-file: LICENSE+copyright: (c) 2014 Zhang Yichao+author: Zhang Yichao <echaozh@gmail.com>+maintainer: Zhang Yichao <echaozh@gmail.com>+category: Web+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ exposed-modules: Web.Scottish,+ Web.Scottish.Database+ Web.Scottish.Database.Persist+ build-depends: base >=4.6 && <4.7+ , data-default >=0.5 && <0.6+ , http-types >= 0.8 && <0.9+ , lens >=3.10 && <4.1+ , mtl >=2.1 && <2.2+ , persistent >=1.3 && <1.4+ , resource-pool >=0.2 && <0.3+ , scotty >=0.6 && <0.8+ , stm >=2.4 && <2.5+ , text >=1.0 && <1.1+ , transformers >=0.3 && <0.4+ , wai >=2.0 && <2.2+ , warp >=2.0.3.3 && <2.2+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-orphans++source-repository head+ type: git+ location: git://github.com/echaozh/scottish.git
+ src/Web/Scottish.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++{- | Scotty apps with configuration and states+-}+module Web.Scottish (+ -- * Types+ Scottish, Scottish'+ , ScottishM, ScottishActionM, ScottishM', ScottishActionM'+ -- * App runners/converters+ , scottish, scottishApp, scottishOpts+ , scottish', scottishApp', scottishOpts', handleRaisedStatus+ -- * Configuratio/State accessors+ -- ** Shared by 'ScottyM' & 'ScottyActionM'+ , getConfig, getGlobalState, getLocalState, (>$<)+ -- ** 'ScottyActionM' only+ , setLocalState, modifyLocalState+ -- ** 'ScottyM' only+ , setConfig, modifyConfig+ , setGlobalState, modifyGlobalState+ -- * Re-exports from Web.Scotty.Trans+ , module Trans+ ) where++import Control.Applicative+import Control.Lens+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Identity++import Data.Default+import Data.IORef+import qualified Data.Text.Lazy as T++import Network.HTTP.Types.Status+import Network.Wai+import Network.Wai.Handler.Warp (Port)++import Web.Scotty.Trans+import qualified Web.Scotty.Trans as Trans hiding (scottyAppT, scottyOptsT,+ scottyT)++data ScottishState c s s' = ScottishState { _config :: c+ , _globalState :: s+ , _localState :: s'+ }++$(makeLenses ''ScottishState)++instance (Default c, Default s, Default s')+ => Default (ScottishState c s s') where+ def = ScottishState def def def++-- | 'config' is read-only in 'ActionT', but read-write in 'ScottyT' for+-- initialization.+--+-- 'localState' is reinitialized to 'def' for every execution of each 'ActionT'.+--+-- 'globalState' may be a TVar, or other monadic mutable data types. Normally,+-- 'globalState' should not be necessary for server apps, as there may be+-- multiple instance of the server running, even across machines, and you sure+-- cannot make them share the same state. However, you may be able to do some+-- process-local caching or user interaction (say in games), with 'globalState'.+newtype Scottish config globalState localState a =+ Scottish { unScottish :: StateT (ScottishState config globalState+ localState) IO a }+ deriving (Functor, Monad, Applicative, MonadIO,+ MonadState (ScottishState config globalState localState))++-- | 'Scottish' monad without 'globalState'+type Scottish' c s' = Scottish c () s'++type ScottishM e c s s' = ScottyT e (Scottish c s s')+type ScottishActionM e c s s' = ActionT e (Scottish c s s')++instance ScottyError Status where+ -- for now, Scotty only `raise`s when input is bad+ stringError = either (const badRequest400) id . (toEnum<$>) . readEither+ . T.pack+ showError = T.pack . show++type ScottishM' c s' = ScottyT Status (Scottish' c s')+type ScottishActionM' c s' = ActionT Status (Scottish' c s')++-- | Run a scottish app with warp.+scottish :: (Default c, Default s, Default s')+ => Port+ -> ScottishM e c s s' ()+ -> IO ()+scottish p = (mkScottishRunners>>=) . flip (uncurry $ scottyT p)++-- | Turn a scottish app into a WAI one, which can be run with any WAI handler.+scottishApp :: (Default c, Default s, Default s')+ => ScottishM e c s s' ()+ -> IO Application+scottishApp = (mkScottishRunners>>=) . flip (uncurry scottyAppT)++-- | Run a scottish app with extra options.+scottishOpts :: (Default c, Default s, Default s')+ => Options -> ScottishM e c s s' () -> IO ()+scottishOpts opts = (mkScottishRunners>>=) . flip (uncurry $ scottyOptsT opts)++-- | Scottish app runner with 'Status' handler installed.+scottish' :: (Default c, Default s, Default s')+ => Port -> ScottishM Status c s s' () -> IO ()+scottish' p = (mkScottishRunners>>=) . flip (uncurry $ scottyT p)+ . handleRaisedStatus++-- | Scottish app converter with 'Status' handler installed.+scottishApp' :: (Default c, Default s, Default s')+ => ScottishM Status c s s' () -> IO Application+scottishApp' = (mkScottishRunners>>=) . flip (uncurry scottyAppT)+ . handleRaisedStatus++-- | Scottish app runner with 'Status' handler installed.+scottishOpts' :: (Default c, Default s, Default s')+ => Options -> ScottishM Status c s s' () -> IO ()+scottishOpts' opts = (mkScottishRunners>>=) . flip (uncurry $ scottyOptsT opts)+ . handleRaisedStatus++mkScottishRunners :: (Default c, Default s, Default s', MonadIO n)+ => IO (forall a. Scottish c s s' a -> n a,+ Scottish c s s' Response -> IO Response)+mkScottishRunners = do+ shared <- newIORef undefined+ let initializer m = liftIO $ do+ (r, ss) <- runStateT (unScottish m) def+ writeIORef shared ss+ return r+ actionRunner m = do+ ss <- readIORef shared+ evalStateT (unScottish m) $ set localState def ss+ return (initializer, actionRunner)++getConfig :: (MonadTrans t) => t (Scottish c s s') c+getConfig = lift . use $ config++getGlobalState :: (MonadTrans t) => t (Scottish c s s') s+getGlobalState = lift . use $ globalState++setConfig :: c -> ScottishM e c s s' ()+setConfig = lift . assign config++modifyConfig :: (c -> c) -> ScottishM e c s s' ()+modifyConfig = lift . (config%=)++setGlobalState :: s -> ScottishM e c s s' ()+setGlobalState = lift . assign globalState++modifyGlobalState :: (s -> s) -> ScottishM e c s s' ()+modifyGlobalState = lift . (globalState%=)++getLocalState :: (ScottyError e) => ScottishActionM e c s s' s'+getLocalState = lift . use $ localState++setLocalState :: (ScottyError e) => s' -> ScottishActionM e c s s' ()+setLocalState = lift . assign localState++modifyLocalState:: (ScottyError e) => (s' -> s') -> ScottishActionM e c s s' ()+modifyLocalState = lift . (localState%=)++-- | 'Status' is a good candidate as an 'ScottyError' instance by itself. Call+-- this function to install a default handler to report the 'Status' when one is+-- raised.+--+-- Also, you may want to define instances of 'ScottyError' with tuples/records+-- containing 'Status', to provide more informative error pages.+handleRaisedStatus :: ScottishM Status c s s' () -> ScottishM Status c s s' ()+handleRaisedStatus = ((defaultHandler $ \e -> status e)>>)++-- | Lift a 'Scottish' function to a 'MonadTrans' wrapped 'Scottish' one.+(>$<) :: MonadTrans t+ => (a -> Scottish c s s' b)+ -> IdentityT (Scottish c s s') a+ -> t (Scottish c s s') b+infixl 4 >$<+f >$< x = lift $ runIdentityT x >>= f
+ src/Web/Scottish/Database.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{- | Database connection pool as an easy part of 'Scottish' app configuration.+-}+module Web.Scottish.Database where++import Control.Lens+import Control.Monad.IO.Class+import Control.Monad.Trans.Class++import Data.Pool (Pool)++import Web.Scottish++class HasDatabaseConnectionPool conn config | config -> conn where+ poolLens :: ALens' config (Pool conn)++instance HasDatabaseConnectionPool conn (Pool conn) where+ poolLens = simple++instance HasDatabaseConnectionPool conn (Pool conn, a) where+ poolLens = _1++instance HasDatabaseConnectionPool conn (a, Pool conn) where+ poolLens = _2++instance HasDatabaseConnectionPool conn (Pool conn, a, b) where+ poolLens = _1++instance HasDatabaseConnectionPool conn (a, Pool conn, b) where+ poolLens = _2++instance HasDatabaseConnectionPool conn (a, b, Pool conn) where+ poolLens = _3++getPool :: (MonadTrans t, HasDatabaseConnectionPool conn config)+ => t (Scottish config s s') (Pool conn)+getPool = return . (^#poolLens) >$< getConfig++setPool :: (HasDatabaseConnectionPool conn config)+ => IO (Pool conn) -- ^ database connection pool creator in IO monad+ -> ScottishM e config s s' ()+setPool f = liftIO f >>= modifyConfig . set (cloneLens poolLens)
+ src/Web/Scottish/Database/Persist.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE FlexibleContexts #-}++{- | Make running Persistent based database transactions easy in Scottish apps.+-}+module Web.Scottish.Database.Persist where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class++import Database.Persist.Sql++import Web.Scottish+import Web.Scottish.Database++runSql :: (MonadTrans t, HasDatabaseConnectionPool Connection config)+ => SqlPersistM a -> t (Scottish config s s') a+runSql s = liftIO . runSqlPersistMPool s >$< getPool