scotty-binding-play (empty) → 1.0
raw patch · 5 files changed
+321/−0 lines, 5 filesdep +HUnitdep +basedep +bytestringsetup-changed
Dependencies added: HUnit, base, bytestring, hspec, http-client, mtl, scotty, template-haskell, text, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Web/Scotty/Binding/Play.hs +132/−0
- scotty-binding-play.cabal +47/−0
- test/Spec.hs +110/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Yusuke Nomura++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 Yusuke Nomura 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Web/Scotty/Binding/Play.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleInstances #-}++-- | The Play Framework style data binding in Scotty.+--+-- Data difinition:+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- >+-- > import Web.Scotty.Binding.Play (deriveBindable)+-- >+-- > data Sample = Sample+-- > { field1 :: Int+-- > , field2 :: Text+-- > }+-- >+-- > deriveBindable ''Sample+--+-- set as GET parameter:+--+-- > > curl http://localhost:3000/?data.field1=1&data.field2=whisky+--+-- We can get 'Sample' in Scotty:+--+-- > main :: IO ()+-- > main = scotty 3000 $ get "/" $ do+-- > a <- parseParam "data"+-- > liftIO $ print $ field1 a --> 1+-- > liftIO $ print $ field2 a --> "whisky"++module Web.Scotty.Binding.Play+ ( Bindable(..)+ , deriveBindable+ ) where++import Control.Monad.Error.Class (catchError)+import Data.ByteString (ByteString)+import Data.Maybe (catMaybes)+import Data.Monoid+import qualified Data.Text as ST+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy.Builder as LTB+import qualified Data.Text.Lazy.Builder.Int as LTB+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Web.Scotty (ActionM, Parsable, param)++-- | Class of generic bindable data structure.+class Bindable a where+ parseParams+ :: Text -- ^ prefix+ -> ActionM a+ parseParams prefix = parseParams' prefix Nothing+ parseParams'+ :: Text -- ^ prefix+ -> Maybe Text -- ^ suffix+ -> ActionM a++instance Bindable a => Bindable [a] where+ parseParams' prefix _ = parseParamList prefix [0..]++instance Bindable Bool where+ parseParams' = parse++instance Bindable Char where+ parseParams' = parse++instance Bindable Double where+ parseParams' = parse++instance Bindable Float where+ parseParams' = parse++instance Bindable Int where+ parseParams' = parse++instance Bindable Integer where+ parseParams' = parse++instance Bindable () where+ parseParams' = parse++instance Bindable ByteString where+ parseParams' = parse++instance Bindable ST.Text where+ parseParams' = parse++instance Bindable Text where+ parseParams' = parse++parse :: Parsable a => Text -> Maybe Text -> ActionM a+parse prefix msuffix = param $ mconcat $ catMaybes [Just prefix, msuffix]++parseParamList :: Bindable a => Text -> [Int] -> ActionM [a]+parseParamList _ [] = fail "not reached"+parseParamList prefix (n:ns) = do+ a <- parseParams' (prefix <> br) Nothing+ as <- parseParamList prefix ns `catchError` \_ -> return []+ return $ a:as+ where+ toText = LTB.toLazyText . LTB.decimal+ br = "[" <> toText n <> "]"++fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a++-- x <- param $ mconcat $ catMaybes [Just pname, Just ".", Just fname, sname]+getParamS :: Name -> Name -> VarStrictType -> Q (Name, StmtQ)+getParamS pname sname (fname, _, _) = do+ x <- newName "x"+ return (x, bindS (varP x)+ [|parseParams (mconcat (catMaybes+ [ Just $(varE pname)+ , Just "."+ , Just $(stringE $ nameBase fname)+ , $(varE sname)+ ]))+ |])++-- | by TH+deriveBindable :: Name -> DecsQ+deriveBindable dat = do+ (TyConI (DataD _ _ _ [RecC dConst vsTypes] _)) <- reify dat+ let pname = mkName "prefix"+ let sname = mkName "msuffix"+ binds <- mapM (getParamS pname sname) vsTypes+ let con = appsE (conE dConst:map (varE . fst) binds)+ let expr = doE (map snd binds ++ [noBindS [|return $con|]])+ [d|+ instance Bindable $(conT dat) where+ parseParams' prefix msuffix = $expr+ |]
+ scotty-binding-play.cabal view
@@ -0,0 +1,47 @@+name: scotty-binding-play+version: 1.0+synopsis: The Play Framework style data binding in Scotty.+description: The Play Framework style data binding in Scotty.+license: BSD3+license-file: LICENSE+author: Yusuke Nomura <yunomu@gmail.com>+maintainer: Yusuke Nomura <yunomu@gmail.com>+homepage: https://github.com/welmo/scotty-binding-play+-- copyright: +category: Web+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Web.Scotty.Binding.Play+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ ghc-options: -Wall+ build-depends: base ==4.*+ , bytestring+ , mtl+ , scotty+ , template-haskell+ , text++test-suite spec+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: ., test+ main-is: Spec.hs+ default-extensions: OverloadedStrings+ ghc-options: -Wall -threaded+ build-depends: base ==4.*+ , bytestring+ , http-client+ , hspec+ , HUnit+ , mtl+ , scotty+ , template-haskell+ , text+ , transformers++source-repository head+ type: git+ location: git://github.com/welmo/scotty-binding-play
+ test/Spec.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Control.Concurrent (forkIO, killThread)+import Control.Exception (bracket)+import Control.Monad.IO.Class (liftIO)+import Data.ByteString (ByteString)+import Data.Text.Lazy (Text)+import Network.HTTP.Client (Request)+import qualified Network.HTTP.Client as HTTP+import Test.Hspec+import Test.HUnit+import Web.Scotty++import Web.Scotty.Binding.Play++port :: Int+port = 3000++host :: String+host = "http://localhost:" ++ show port++withScotty :: ScottyM () -> IO a -> IO ()+withScotty app f = bracket+ (forkIO $ scotty port app)+ killThread+ (const $ f >> return ())++type SMethod = RoutePattern -> ActionM () -> ScottyM ()++data Method = GET | POST++toS :: Method -> ActionM () -> ScottyM ()+toS GET = get "/"+toS POST = post "/"++p :: Method -> [(ByteString, ByteString)] -> Request -> Request+p GET = HTTP.setQueryString . map (\(k, v) -> (k, Just v))+p POST = HTTP.urlEncodedBody++http :: (Request -> Request) -> IO ()+http f = HTTP.withManager HTTP.defaultManagerSettings $ \mgr -> do+ req <- HTTP.parseUrl $ host ++ "/"+ _ <- HTTP.httpNoBody (f req) mgr+ return ()++data Test1 = Test1+ { field1 :: Int+ , field2 :: Text+ }+ deriving (Show, Eq)++deriveBindable ''Test1++testServer :: (Eq a, Show a, Bindable a)+ => (ActionM () -> b) -> a -> b+testServer m d = m $ do+ t1 <- parseParams "data"+ liftIO $ d @=? t1++test :: (Eq a, Show a, Bindable a)+ => Method -> a -> [(ByteString, ByteString)] -> IO ()+test m ex = withScotty (testServer (toS m) ex) . http . p m++data Test2 = Test2+ { field21 :: [Text]+ }+ deriving (Show, Eq)++deriveBindable ''Test2++data Test3 = Test3+ { field31 :: Test1+ , field32 :: Test2+ }+ deriving (Show, Eq)++deriveBindable ''Test3++main :: IO ()+main = hspec $ do+ describe "Web.Scotty.Binding.Play" $ do+ let ex1 = Test1 1 "test"+ let ac1 =+ [ ("data.field1", "1")+ , ("data.field2", "test")+ ]+ it "bind data GET" $ test GET ex1 ac1+ it "bind data POST" $ test POST ex1 ac1+ let ex2 = 1 :: Int+ let ac2 = [("data", "1")]+ it "bind simple data GET" $ test GET ex2 ac2+ it "bind simple data POST" $ test POST ex2 ac2+ let ex3 = Test2 ["text1", "text2"]+ let ac3 =+ [ ("data.field21[0]", "text1")+ , ("data.field21[1]", "text2")+ ]+ it "bind array data GET" $ test GET ex3 ac3+ it "bind array data POST" $ test POST ex3 ac3+ let ex4 = Test3 ex1 ex3+ let ac4 =+ [ ("data.field31.field1", "1")+ , ("data.field31.field2", "test")+ , ("data.field32.field21[0]", "text1")+ , ("data.field32.field21[1]", "text2")+ ]+ it "bind nested data GET" $ test GET ex4 ac4+ it "bind nested data POST" $ test POST ex4 ac4