{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
module Main
( main
, waiSite
) where
import Test.Framework (defaultMain)
import Test.Framework.Providers.QuickCheck2
import Web.Routes.Quasi
import Test.QuickCheck
import Control.Applicative
import Network.Wai
import Network.Wai.Enumerator
--import Network.Wai.Handler.SimpleServer
import Data.ByteString.Lazy.Char8 (pack)
import Data.ByteString.Char8 (unpack)
import Web.Routes.Site
import Language.Haskell.TH.Syntax
import Web.Encodings
data StaticArgs = StaticArgs
getStaticArgs :: Int -> StaticArgs
getStaticArgs _ = StaticArgs
data StaticRoutes = StaticRoutes { unStaticRoutes :: [String] }
deriving (Show, Read, Eq)
type instance Routes StaticArgs = StaticRoutes
siteStatic :: QuasiSite Application StaticArgs marg
siteStatic = QuasiSite
undefined
unStaticRoutes
(Right . StaticRoutes)
type Explode surl murl marg = (murl -> String)
-> surl
-> (surl -> murl)
-> marg
-> (marg -> Int)
-> Application
-> String
-> Application
explode :: Explode surl murl marg -> Explode surl murl marg
explode = id
fmap (\(QuasiSiteDecs a b c d) -> [a, b, c, d])
$ createQuasiSite QuasiSiteSettings
{ crRoutes = mkName "MyRoutes"
, crApplication = ConT ''Application
, crArgument = ConT ''Int
, crExplode = VarE $ mkName "explode"
, crResources = [$parseRoutes|
/ Home GET
/user/#Integer User GET PUT DELETE
/static Static StaticArgs siteStatic getStaticArgs
/foo/*Strings Foo
/bar/#String Bar
|]
, crSite = mkName "theSite"
, crMaster = Left $ ConT ''Int
}
handleFoo :: [String] -> Explode MyRoutes murl marg
handleFoo a mrender _surl tomurl _marg _tosarg _badmethod _method _req = return $ Response
Status200
[]
$ Right $ fromLBS $ pack $ show ("in foo", mrender $ tomurl $ User 78, a)
handleBar :: String -> Explode MyRoutes murl marg
handleBar a mrender _surl tomurl _marg _tosarg _badmethod _method _req = return $ Response
Status200
[]
$ Right $ fromLBS $ pack $ show ("in bar", mrender $ tomurl $ User 78, a)
getHome :: Explode MyRoutes murl marg
getHome mrender _surl tomurl marg tosarg _badmethod _method _req = return $ Response
Status200
[]
$ Right $ fromLBS $ pack $ show
[ show $ tosarg marg
, mrender $ tomurl $ Foo ["bar baz+bin"]
]
getUser :: Integer -> Explode MyRoutes murl marg
getUser uid mrender _surl tomurl marg tosarg _badmethod _method _req = return $ Response
Status200
[]
$ Right $ fromLBS $ pack $ unlines
[ "Getting user"
, show uid
, show $ tosarg marg
, mrender $ tomurl Home
]
putUser :: Integer -> Explode MyRoutes murl marg
putUser = undefined
deleteUser :: Integer -> Explode MyRoutes murl marg
deleteUser = undefined
msg404 :: String -> Application
msg404 s _ = return $ Response
Status404
[]
$ Right $ fromLBS $ pack $ "Not found: " ++ s
{-
badMethod :: Application
badMethod _ = return $ Response
Status200
[]
$ Right $ fromLBS $ pack "Bad method"
-}
main :: IO ()
main = defaultMain
[ testSuite
, testProperty "parse/render id" $
\r -> quasiParse theSite (quasiRender theSite r) == Right r
]
instance Arbitrary MyRoutes where
arbitrary = oneof
[ return Home
, User <$> arbitrary
, Static . StaticRoutes <$> arbitrary
, Foo <$> arbitrary
, Bar <$> arbitrary
]
waiSite :: Site a Application -> Application
waiSite s req = do
let pi' = unpack $ pathInfo req
pis = splitPath $ drop1Slash pi'
url = parsePathSegments s pis
case url of
Left s' -> msg404 s' req
Right u -> handleSite s (joinPath "http://localhost:3000/" . formatPathSegments s) u req
joinPath :: String -> [String] -> String
joinPath s [] = s
joinPath s (x:xs) = joinPath (s ++ encodeUrl x ++ "/") xs
splitPath :: String -> [String]
splitPath "" = []
splitPath x =
let (y, z) = break (== '/') x
in y : splitPath (drop1Slash z)
drop1Slash :: String -> String
drop1Slash ('/':x) = x
drop1Slash x = x
#if TEST
testSuite :: Test
testSuite = testGroup "Web.Routes.Quasi"
[ testCase "overlaps" caseOverlaps
, testCase "complete" caseComplete
]
caseOverlaps :: Assertion
caseOverlaps = do
assertBool "empty" $ null $ findOverlaps []
assertBool "single" $ null $ findOverlaps
[ Resource "Foo" [] $ Single "foo"
]
assertBool "two empties" $ not $ null $ findOverlaps
[ Resource "Foo" [] $ Single "foo"
, Resource "Bar" [] $ Single "bar"
]
assertBool "slurp versus empty" $ not $ null $ findOverlaps
[ Resource "Foo" [] $ Single "foo"
, Resource "Bar" [] $ SubSite "a" "b" "c"
]
assertBool "static + slurp versus empty" $ null $ findOverlaps
[ Resource "Foo" [] $ Single "foo"
, Resource "Bar" [StaticPiece "5"] $ SubSite "a" "b" "c"
]
caseComplete :: Assertion
caseComplete = do
assertBool "empty" $ not $ areResourcesComplete []
assertBool "slurp" $ areResourcesComplete
[ Resource "Foo" [MultiPiece "Foos"] $ Single "foo"
]
assertBool "subsite" $ areResourcesComplete
[ Resource "Foo" [] $ SubSite "a" "b" "c"
]
assertBool "string + subsite" $ areResourcesComplete
[ Resource "Foo" [SinglePiece "Foo"] $ SubSite "a" "b" "c"
, Resource "Bar" [] $ Single "bar"
]
assertBool "static + subsite" $ not $ areResourcesComplete
[ Resource "Foo" [StaticPiece "foo"] $ SubSite "a" "b" "c"
]
assertBool "two pieces" $ not $ areResourcesComplete
[ Resource "Foo" [SinglePiece "Foo"] $ Single "foo"
, Resource "Bar" [StaticPiece "foo"] $ SubSite "a" "b" "c"
]
#endif