packages feed

apiary (empty) → 0.1.0.0

raw patch · 11 files changed

+531/−0 lines, 11 filesdep +aesondep +basedep +blaze-buildersetup-changed

Dependencies added: aeson, base, blaze-builder, bytestring, conduit, data-default, http-types, mime-types, mmorph, monad-control, monad-logger, mtl, template-haskell, text, transformers, transformers-base, wai

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 philopon++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ apiary.cabal view
@@ -0,0 +1,82 @@+-- Initial apiary.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                apiary+version:             0.1.0.0+synopsis:            Simple web framework inspired by scotty.+description:+  Simple web framework inspired by scotty.+  .+  @+  &#123;-# LANGUAGE QuasiQuotes #-&#125;+  &#123;-# LANGUAGE OverloadedStrings #-&#125;+  .+  import Web.Apiary+  import Network.Wai.Handler.Warp+  import qualified Data.ByteString.Lazy.Char8 as L+  .+  main :: IO ()+  main = run 3000 . runApiaryT def $ do+  &#32;&#32;[capture|/:String|] $ do+  &#32;&#32;&#32;&#32;stdMethod GET . action $ \\name -> do+  &#32;&#32;&#32;&#32;&#32;&#32;contentType "text/html"+  &#32;&#32;&#32;&#32;&#32;&#32;lbs . L.concat $ ["&#60;h1&#62;Hello, ", L.pack name, "!&#60;/h1&#62;"]+  @+  .+  * Nestable route handling(ApiaryT Monad; capture, stdMethod and more.).+  * type safe path capture.+  .+  full example & tutorial: <https://github.com/philopon/apiary/blob/master/examples/main.lhs>++license:             MIT+license-file:        LICENSE+author:              HirotomoMoriwaki+maintainer:          philopon.dependence@gmail.com+-- copyright:           +category:            Web+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++flag MonadLogger+  description: define MonadLogger instance+  default: True++library+  exposed-modules:     Web.Apiary+                       Web.Apiary.QQ+                       Control.Monad.Apiary+                       Control.Monad.Apiary.Filter+                       Control.Monad.Apiary.Action+  other-modules:       Web.Apiary.QQ.Capture+                       Control.Monad.Apiary.Internal+                       Control.Monad.Apiary.Action.Internal+  other-extensions:    TemplateHaskell+                       FlexibleInstances+                       LambdaCase+  build-depends:       base              >=4.7 && <4.8+                     , template-haskell  >=2.9 && <2.10+                     , transformers      >=0.3 && <0.5+                     , mtl               >=2.1 && <2.3+                     , monad-control     >=0.3 && <0.4+                     , mmorph            >=1.0 && <1.1+                     , transformers-base >=0.4 && <0.5++                     , text              >=1.1 && <1.2+                     , bytestring        >=0.10 && <0.11+                     , blaze-builder     >=0.3 && <0.4+                     , conduit           >=1.1 && <1.2+                     , data-default      >=0.5 && <0.6+                     , aeson             >=0.7 && <0.8++                     , http-types        >=0.8 && <0.9+                     , mime-types        >=0.1 && <0.2+                     , wai               >=2.1 && <2.2++  if flag(MonadLogger)+    build-depends:     monad-logger      >=0.3 && <0.4+    cpp-options:       -DDefineMonadLoggerInstance++  hs-source-dirs:      src+  ghc-options:         -O2 -Wall -threaded+  default-language:    Haskell2010
+ src/Control/Monad/Apiary.hs view
@@ -0,0 +1,13 @@+module Control.Monad.Apiary+    ( ApiaryT+    , runApiaryT+    -- * getter+    , apiaryConfig+    -- * execute action+    , action, action_+    -- * Reexport+    , module Control.Monad.Apiary.Filter+    ) where++import Control.Monad.Apiary.Internal+import Control.Monad.Apiary.Filter
+ src/Control/Monad/Apiary/Action.hs view
@@ -0,0 +1,26 @@+module Control.Monad.Apiary.Action +    (+      ActionT+    , ApplicationM+    , ApiaryConfig(..)+    -- * actions+    -- ** getter+    , getRequest+    -- ** setter+    , status+    -- *** response header+    , addHeader, setHeaders, modifyHeader+    , contentType+    -- *** response body+    , file+    , file'+    , builder+    , lbs+    , source+    , json+    -- * Reexport+    , def+    ) where++import Control.Monad.Apiary.Action.Internal+import Data.Default
+ src/Control/Monad/Apiary/Action/Internal.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}++module Control.Monad.Apiary.Action.Internal where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Base+import Control.Monad.Trans.State.Strict+import Control.Monad.Reader+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Control+import Network.Wai+import Network.Mime+import Data.Default+import Data.Monoid+import Network.HTTP.Types+import Blaze.ByteString.Builder+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T+import Data.Conduit+import Data.Aeson+import Control.Monad.Morph++#ifdef DefineMonadLoggerInstance+import qualified Control.Monad.Logger as Logger+#endif++data ApiaryConfig m = ApiaryConfig+    { -- | call when no handler matched.+      notFound      :: ApplicationM m +      -- | used unless call 'status' function.+    , defaultStatus :: Status+      -- | initial headers.+    , defaultHeader :: ResponseHeaders+      -- | used by 'Control.Monad.Apiary.Filter.root' filter.+    , rootPattern   :: [S.ByteString]+    , mimeType      :: FilePath -> S.ByteString+    }++data ApiaryConfig' = ApiaryConfig'+    { defaultStatus' :: Status+    , defaultHeader' :: ResponseHeaders+    , rootPattern'   :: [S.ByteString]+    , mimeType'      :: FilePath -> S.ByteString+    }++subConfig :: ApiaryConfig m -> ApiaryConfig'+subConfig (ApiaryConfig _ a b c d) = ApiaryConfig' a b c d++instance Monad m => Default (ApiaryConfig m) where+    def = ApiaryConfig +        { notFound = \_ -> return $ responseLBS status404 +            [("Content-Type", "text/plain")] "404 Page Notfound."+        , defaultStatus = ok200+        , defaultHeader = []+        , rootPattern   = ["", "/", "/index.html", "/index.htm"]+        , mimeType      = defaultMimeLookup . T.pack+        }++type ApplicationM m = Request -> m Response++data ActionState = ActionState+    { actionStatus  :: Status+    , actionHeaders :: ResponseHeaders+    , actionBody    :: Body+    }++data Body +    = File FilePath (Maybe FilePart)+    | Builder Builder+    | LBS L.ByteString+    | SRC (Source IO (Flush Builder))++actionStateToResponse :: ActionState -> Response+actionStateToResponse as = case actionBody as of+    File f p  -> responseFile st hd f p+    Builder b -> responseBuilder st hd b+    LBS l     -> responseLBS st hd l+    SRC    s  -> responseSource st hd s+  where+    st = actionStatus  as+    hd = actionHeaders as++newtype ActionT m a = ActionT+    { unActionT :: ReaderT ApiaryConfig' (ReaderT Request (StateT ActionState (MaybeT m))) a +    } deriving (Functor, Applicative, Monad, MonadIO)++instance MonadTrans ActionT where+    lift = ActionT . lift . lift . lift . lift++runActionT :: ActionT m a -> ApiaryConfig' -> Request -> ActionState -> m (Maybe (a, ActionState))+runActionT (ActionT m) config request st = runMaybeT (runStateT (runReaderT (runReaderT m config) request) st)++actionT :: (ApiaryConfig' -> Request -> ActionState -> m (Maybe (a, ActionState))) -> ActionT m a+actionT f = ActionT . ReaderT $ \c -> ReaderT $ \r -> StateT $ \s -> MaybeT $ f c r s++execActionT :: Monad m => ApiaryConfig m -> ActionT m () -> (ApplicationM m)+execActionT config m request = runActionT m (subConfig config) request resp >>= \case+        Nothing    -> notFound config request+        Just (_,r) -> return $ actionStateToResponse r+  where+    resp = ActionState (defaultStatus config) (defaultHeader config) (LBS "")++instance (Monad m, Functor m) => Alternative (ActionT m) where+    empty = mzero+    (<|>) = mplus++instance Monad m => MonadPlus (ActionT m) where+    mzero = actionT $ \_ _ _ -> return Nothing+    mplus m n = actionT $ \c r s -> runActionT m c r s >>= \case+        Just a  -> return $ Just a+        Nothing -> runActionT n c r s++instance Monad m => Monoid (ActionT m ()) where+    mempty  = mzero+    mappend = mplus++instance MonadBase b m => MonadBase b (ActionT m) where+    liftBase = liftBaseDefault++instance MonadTransControl ActionT where+    newtype StT ActionT a = StAction { unStAction :: StT MaybeT (StT (StateT ActionState) (StT (ReaderT Request) (StT (ReaderT ApiaryConfig') a))) }+    liftWith f = ActionT $ liftWith $ \run -> liftWith $ \run' -> liftWith $ \run'' -> liftWith $ \run''' -> +        f $ liftM StAction . run''' . run'' . run' . run . unActionT+    restoreT = ActionT . restoreT . restoreT . restoreT . restoreT . liftM unStAction++instance MonadBaseControl b m => MonadBaseControl b (ActionT m) where+    newtype StM (ActionT m) a = StMT { unStMT :: ComposeSt ActionT m a }+    liftBaseWith = defaultLiftBaseWith StMT+    restoreM     = defaultRestoreM   unStMT++instance MFunctor ActionT where+    hoist nat m = actionT $ \c r s ->+        nat $ runActionT m c r s++instance MonadReader r m => MonadReader r (ActionT m) where+    ask     = lift ask+    local f = hoist $ local f++#ifdef DefineMonadLoggerInstance+instance Logger.MonadLogger m => Logger.MonadLogger (ActionT m) where+    monadLoggerLog loc src lv msg = lift $ Logger.monadLoggerLog loc src lv msg+#endif++getRequest :: Monad m => ActionT m Request+getRequest = ActionT $ lift ask++modifyState :: Monad m => (ActionState -> ActionState) -> ActionT m ()+modifyState f = ActionT . lift . lift $ modify f++status :: Monad m => Status -> ActionT m ()+status st = modifyState (\s -> s { actionStatus = st } )++modifyHeader :: Monad m => (ResponseHeaders -> ResponseHeaders) -> ActionT m ()+modifyHeader f = modifyState (\s -> s {actionHeaders = f $ actionHeaders s } )++addHeader :: Monad m => Header -> ActionT m ()+addHeader h = modifyHeader (h:)++setHeaders :: Monad m => ResponseHeaders -> ActionT m ()+setHeaders hs = modifyHeader (const hs)++contentType :: Monad m => S.ByteString -> ActionT m ()+contentType c = modifyHeader (\h -> ("Content-Type", c) : filter (("Content-Type" /=) . fst) h)++-- | set body to file content and detect Content-Type by extension.+file :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()+file f p = do+    mime <- ActionT $ asks mimeType'+    contentType (mime f)+    file' f p++file' :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()+file' f p = modifyState (\s -> s { actionBody = File f p } )++builder :: Monad m => Builder -> ActionT m ()+builder b = modifyState (\s -> s { actionBody = Builder b } )++lbs :: Monad m => L.ByteString -> ActionT m ()+lbs l = modifyState (\s -> s { actionBody = LBS l } )++source :: Monad m => Source IO (Flush Builder) -> ActionT m ()+source src = modifyState (\s -> s { actionBody = SRC src } )++-- | set body to j and set Content-Type to \"application/json\"+json :: (ToJSON j, Monad m) => j -> ActionT m ()+json j = do+    contentType "application/json"+    lbs $ encode j
+ src/Control/Monad/Apiary/Filter.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Control.Monad.Apiary.Filter+    ( method, stdMethod, root+    , ssl, hasQuery+    , function, function'+    -- * Reexport+    , StdMethod(..)+    ) where++import Control.Monad+import Network.Wai+import Network.HTTP.Types+import qualified Data.ByteString as S++import Control.Monad.Apiary.Action.Internal+import Control.Monad.Apiary.Internal++-- | raw filter function.+function :: Monad m => (c -> Request -> Maybe c') -> ApiaryT c' m a -> ApiaryT c m a+function f = focus $ \c -> getRequest >>= \r -> case f c r of+    Nothing -> mzero+    Just c' -> return c'++function' :: Monad m => (Request -> Bool) -> ApiaryT c m a -> ApiaryT c m a+function' f = function $ \c r -> if f r then Just c else Nothing++ssl :: Monad m => ApiaryT c m a -> ApiaryT c m a+ssl = function' isSecure++hasQuery :: Monad m => S.ByteString -> ApiaryT c m a -> ApiaryT c m a+hasQuery q = function' (any ((q ==) . fst) . queryString)++method :: Monad m => Method -> ApiaryT c m a -> ApiaryT c m a+method m = function' $ ((m ==) . requestMethod)++stdMethod :: Monad m => StdMethod -> ApiaryT c m a -> ApiaryT c m a+stdMethod = method . renderStdMethod++-- | filter by 'Control.Monad.Apiary.Action.rootPattern' of 'Control.Monad.Apiary.Action.ApiaryConfig'.+root :: Monad m => ApiaryT c m b -> ApiaryT c m b+root m = do+    rs <- rootPattern `liftM` apiaryConfig+    function (\c r -> if rawPathInfo r `elem` rs then Just c else Nothing) m+
+ src/Control/Monad/Apiary/Internal.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Control.Monad.Apiary.Internal where++import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Trans.Writer+import Control.Monad.Trans.Reader++import Control.Monad.Apiary.Action.Internal++newtype ApiaryT c m a = ApiaryT { unApiaryT :: ReaderT (ActionT m c) (ReaderT (ApiaryConfig m) (Writer (ActionT m ()))) a }+    deriving (Functor, Applicative, Monad)++runApiaryT' :: Monad m => ApiaryConfig m -> ApiaryT c m a -> ActionT m c -> ApplicationM m+runApiaryT' config (ApiaryT m) = execActionT config . execWriter . flip runReaderT config . runReaderT m++runApiaryT :: Monad m => ApiaryConfig m -> ApiaryT () m a -> ApplicationM m+runApiaryT conf m = runApiaryT' conf m $ return ()++apiaryConfig :: Monad m => ApiaryT c m (ApiaryConfig m)+apiaryConfig = ApiaryT $ lift ask++focus :: Monad m => (c -> ActionT m c') -> ApiaryT c' m a -> ApiaryT c m a+focus f (ApiaryT m) = ApiaryT . ReaderT $ \c -> runReaderT m (c >>= f)++action_ :: Monad m => ActionT m () -> ApiaryT c m ()+action_ a = action (const a)++action :: Monad m => (c -> ActionT m ()) -> ApiaryT c m ()+action a = ApiaryT $ ask >>= \g -> (lift . lift) (tell $ g >>= a)+
+ src/Web/Apiary.hs view
@@ -0,0 +1,10 @@+module Web.Apiary +    (+      module Control.Monad.Apiary+    , module Control.Monad.Apiary.Action+    , module Web.Apiary.QQ+    ) where++import Control.Monad.Apiary+import Control.Monad.Apiary.Action+import Web.Apiary.QQ
+ src/Web/Apiary/QQ.hs view
@@ -0,0 +1,5 @@+module Web.Apiary.QQ+    (capture+    ) where++import Web.Apiary.QQ.Capture
+ src/Web/Apiary/QQ/Capture.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}++module Web.Apiary.QQ.Capture where++import Control.Monad+import Network.Wai+import Text.Read+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Data.Int+import Data.Word++import Control.Monad.Apiary++preCapture :: [Char] -> [T.Text]+preCapture ('/':s) = T.splitOn "/" $ T.pack s+preCapture s       = T.splitOn "/" $ T.pack s++capture :: QuasiQuoter+capture = QuasiQuoter+    { quoteExp  = capture' . preCapture+    , quotePat  = \_ -> error "No quotePat."+    , quoteType = \_ -> error "No quoteType."+    , quoteDec  = \_ -> error "No quoteDec."+    }++class Param a where+  readParam :: T.Text -> Maybe a++instance Param Char where+    readParam s | T.null s  = Nothing+                | otherwise = Just $ T.head s++instance Param Int     where readParam = readMaybe . T.unpack+instance Param Int8    where readParam = readMaybe . T.unpack+instance Param Int16   where readParam = readMaybe . T.unpack+instance Param Int32   where readParam = readMaybe . T.unpack+instance Param Int64   where readParam = readMaybe . T.unpack+instance Param Integer where readParam = readMaybe . T.unpack++instance Param Word   where readParam = readMaybe . T.unpack+instance Param Word8  where readParam = readMaybe . T.unpack+instance Param Word16 where readParam = readMaybe . T.unpack+instance Param Word32 where readParam = readMaybe . T.unpack+instance Param Word64 where readParam = readMaybe . T.unpack++instance Param Double  where readParam = readMaybe . T.unpack+instance Param Float   where readParam = readMaybe . T.unpack++instance Param T.Text where+    readParam = Just++instance Param TL.Text where+    readParam = Just . TL.fromStrict++instance Param String where+    readParam = Just . T.unpack++integralE :: Integral i => i -> ExpQ+integralE = litE . integerL . fromIntegral++capture' :: [T.Text] -> ExpQ+capture' cap = [| function $ \_ request -> +    $(caseE [|pathInfo request|] +        [ match pat   (guards >>= \g -> body >>= \b -> normalB (doE $ g ++ b)) []+        , match wildP (normalB  [|mzero|]) []+        ]) |]+  where+    varNames = zip cap $ map (('v':) . show) [0 :: Int ..]+    pat      = listP $ map (varP . mkName . snd) varNames+    isType s | T.null s        = False+             | T.head s == ':' = True+             | otherwise       = False+    guards = return $ +        map (\(a,v) -> noBindS [|guard $ $(varE $ mkName v) == $(stringE $ T.unpack a) |]) $+        filter (not . isType . fst) varNames+    body = do+        let ss = map (\(a,v) -> do+                ty <- lookupType a+                -- let ty = mkName . T.unpack $ T.tail a+                bindS (varP . mkName $ v ++ "'")+                    [| (readParam $(varE $ mkName v) :: Maybe $(conT ty) ) |])+                    $ filter (isType . fst) varNames+            rt = tupE $ map (\(_,v) -> varE $ mkName (v ++ "'")) $ filter (isType . fst) varNames+        return $ ss ++ [noBindS [| return $rt |]]+    lookupType n =  lookupTypeName (T.unpack $ T.tail n) >>= \case+        Nothing -> fail $ "capture': type not found: " ++ T.unpack (T.tail n)+        Just ty -> return ty++