diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -1,5 +1,5 @@ name: apiary -version: 0.2.0.0 +version: 0.3.0.0 x-revision: 1 synopsis: Simple web framework inspired by scotty. description: @@ -40,17 +40,13 @@ -- extra-source-files: cabal-version: >=1.10 -flag MonadLogger - description: define MonadLogger instance - default: True - library exposed-modules: Web.Apiary - Web.Apiary.QQ + Web.Apiary.TH Control.Monad.Apiary Control.Monad.Apiary.Filter Control.Monad.Apiary.Action - other-modules: Web.Apiary.QQ.Capture + other-modules: Web.Apiary.TH.Capture Control.Monad.Apiary.Internal Control.Monad.Apiary.Action.Internal other-extensions: TemplateHaskell @@ -68,15 +64,13 @@ , bytestring >=0.10 && <0.11 , blaze-builder >=0.3 && <0.4 , conduit >=1.1 && <1.2 + , monad-logger >=0.3 && <0.4 , data-default >=0.5 && <0.6 , 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 + , warp >=2.1 && <2.2 hs-source-dirs: src ghc-options: -O2 -Wall diff --git a/src/Control/Monad/Apiary/Action/Internal.hs b/src/Control/Monad/Apiary/Action/Internal.hs --- a/src/Control/Monad/Apiary/Action/Internal.hs +++ b/src/Control/Monad/Apiary/Action/Internal.hs @@ -7,7 +7,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE CPP #-} module Control.Monad.Apiary.Action.Internal where @@ -30,10 +29,7 @@ import qualified Data.Text as T import Data.Conduit import Control.Monad.Morph - -#ifdef DefineMonadLoggerInstance import qualified Control.Monad.Logger as Logger -#endif data ApiaryConfig = ApiaryConfig { -- | call when no handler matched. @@ -139,10 +135,8 @@ 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 diff --git a/src/Web/Apiary.hs b/src/Web/Apiary.hs --- a/src/Web/Apiary.hs +++ b/src/Web/Apiary.hs @@ -2,9 +2,9 @@ ( module Control.Monad.Apiary , module Control.Monad.Apiary.Action - , module Web.Apiary.QQ + , module Web.Apiary.TH ) where import Control.Monad.Apiary import Control.Monad.Apiary.Action -import Web.Apiary.QQ +import Web.Apiary.TH diff --git a/src/Web/Apiary/QQ.hs b/src/Web/Apiary/QQ.hs deleted file mode 100644 --- a/src/Web/Apiary/QQ.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Web.Apiary.QQ - (capture - ) where - -import Web.Apiary.QQ.Capture diff --git a/src/Web/Apiary/QQ/Capture.hs b/src/Web/Apiary/QQ/Capture.hs deleted file mode 100644 --- a/src/Web/Apiary/QQ/Capture.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# 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 - - diff --git a/src/Web/Apiary/TH.hs b/src/Web/Apiary/TH.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/TH.hs @@ -0,0 +1,5 @@ +module Web.Apiary.TH + (capture + ) where + +import Web.Apiary.TH.Capture diff --git a/src/Web/Apiary/TH/Capture.hs b/src/Web/Apiary/TH/Capture.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/TH/Capture.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} + +module Web.Apiary.TH.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 + +