diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/scottish.cabal b/scottish.cabal new file mode 100644 --- /dev/null +++ b/scottish.cabal @@ -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] + +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 +maintainer: Zhang Yichao +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 diff --git a/src/Web/Scottish.hs b/src/Web/Scottish.hs new file mode 100644 --- /dev/null +++ b/src/Web/Scottish.hs @@ -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 diff --git a/src/Web/Scottish/Database.hs b/src/Web/Scottish/Database.hs new file mode 100644 --- /dev/null +++ b/src/Web/Scottish/Database.hs @@ -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) diff --git a/src/Web/Scottish/Database/Persist.hs b/src/Web/Scottish/Database/Persist.hs new file mode 100644 --- /dev/null +++ b/src/Web/Scottish/Database/Persist.hs @@ -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