module Yesod.Dispatch
(
parseRoutes
, mkYesod
, mkYesodSub
, mkYesodData
, mkYesodDispatch
, SinglePiece (..)
, MultiPiece (..)
, Strings
, toWaiApp
, basicHandler
, basicHandler'
, fullRender
#if TEST
, testSuite
#endif
) where
import Yesod.Handler
import Yesod.Yesod
import Yesod.Request
import Yesod.Internal
import Web.Routes.Quasi
import Web.Routes.Quasi.Parse
import Web.Routes.Quasi.TH
import Web.Routes.Site
import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
import Network.Wai.Middleware.CleanPath
import Network.Wai.Middleware.Jsonp
import Network.Wai.Middleware.Gzip
import qualified Network.Wai.Handler.SimpleServer as SS
import qualified Network.Wai.Handler.CGI as CGI
import System.Environment (getEnvironment)
import qualified Data.ByteString.Char8 as B
import Web.Routes (encodePathInfo)
import qualified Data.ByteString.UTF8 as S
import Control.Concurrent.MVar
import Control.Arrow ((***))
import Data.Time
import Control.Monad
import Data.Maybe
import Web.ClientSession
import qualified Web.ClientSession as CS
import Data.Char (isLower, isUpper)
import Data.Serialize
import qualified Data.Serialize as Ser
import Network.Wai.Parse hiding (FileInfo)
import qualified Network.Wai.Parse as NWP
import Data.String (fromString)
#if TEST
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck
import System.IO.Unsafe
import Yesod.Content hiding (testSuite)
import Data.Serialize.Get
import Data.Serialize.Put
#else
import Yesod.Content
#endif
mkYesod :: String
-> [Resource]
-> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
mkYesodSub :: String
-> [(String, [Name])]
-> [Resource]
-> Q [Dec]
mkYesodSub name clazzes =
fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
where
(name':rest) = words name
mkYesodData :: String -> [Resource] -> Q [Dec]
mkYesodData name res = do
(x, _) <- mkYesodGeneral name [] [] False res
let rname = mkName $ "resources" ++ name
eres <- lift res
let y = [ SigD rname $ ListT `AppT` ConT ''Resource
, FunD rname [Clause [] (NormalB eres) []]
]
return $ x ++ y
mkYesodDispatch :: String -> [Resource] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
typeHelper :: String -> Type
typeHelper =
foldl1 AppT . map go . words
where
go s@(x:_)
| isLower x = VarT $ mkName s
| otherwise = ConT $ mkName s
go [] = error "typeHelper: empty string to go"
mkYesodGeneral :: String
-> [String]
-> [(String, [Name])]
-> Bool
-> [Resource]
-> Q ([Dec], [Dec])
mkYesodGeneral name args clazzes isSub res = do
let name' = mkName name
args' = map mkName args
arg = foldl AppT (ConT name') $ map VarT args'
let clazzes' = map (\(x, y) -> ClassP x [typeHelper y])
$ concatMap (\(x, y) -> zip y $ repeat x)
$ compact
$ map (\x -> (x, [])) ("master" : args) ++ clazzes
th <- mapM (thResourceFromResource arg) res
w' <- createRoutes th
let routesName = mkName $ name ++ "Route"
let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
let x = TySynInstD ''Route [arg] $ ConT routesName
parse' <- createParse th
parse'' <- newName "parse"
let parse = LetE [FunD parse'' parse'] $ VarE parse''
render' <- createRender th
render'' <- newName "render"
let render = LetE [FunD render'' render'] $ VarE render''
tmh <- [|toMasterHandler|]
modMaster <- [|fmap chooseRep|]
dispatch' <- createDispatch modMaster tmh th
dispatch'' <- newName "dispatch"
let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch''
site <- [|Site|]
let site' = site `AppE` dispatch `AppE` render `AppE` parse
let (ctx, ytyp, yfunc) =
if isSub
then (clazzes', ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite")
else ([], ConT ''YesodSite `AppT` arg, "getSite")
let y = InstanceD ctx ytyp
[ FunD (mkName yfunc) [Clause [] (NormalB site') []]
]
return ([w, x], [y])
isStatic :: Piece -> Bool
isStatic StaticPiece{} = True
isStatic _ = False
fromStatic :: Piece -> String
fromStatic (StaticPiece s) = s
fromStatic _ = error "fromStatic"
thResourceFromResource :: Type -> Resource -> Q THResource
thResourceFromResource _ (Resource n ps attribs)
| all (all isUpper) attribs = return (n, Simple ps attribs)
thResourceFromResource master (Resource n ps atts@[stype, toSubArg])
| all isStatic ps && any (any isLower) atts = do
let stype' = ConT $ mkName stype
gss <- [|getSubSite|]
let inside = ConT ''Maybe `AppT`
(ConT ''GHandler `AppT` stype' `AppT` master `AppT`
ConT ''ChooseRep)
let typ = ConT ''Site `AppT`
(ConT ''Route `AppT` stype') `AppT`
(ArrowT `AppT` ConT ''String `AppT` inside)
let gss' = gss `SigE` typ
parse' <- [|parsePathSegments|]
let parse = parse' `AppE` gss'
render' <- [|formatPathSegments|]
let render = render' `AppE` gss'
dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|]
let dispatch = dispatch' `AppE` gss'
return (n, SubSite
{ ssType = ConT ''Route `AppT` stype'
, ssParse = parse
, ssRender = render
, ssDispatch = dispatch
, ssToMasterArg = VarE $ mkName toSubArg
, ssPieces = map fromStatic ps
})
thResourceFromResource _ (Resource n _ _) =
error $ "Invalid attributes for resource: " ++ n
compact :: [(String, [a])] -> [(String, [a])]
compact [] = []
compact ((x, x'):rest) =
let ys = filter (\(y, _) -> y == x) rest
zs = filter (\(z, _) -> z /= x) rest
in (x, x' ++ concatMap snd ys) : compact zs
sessionName :: String
sessionName = "_SESSION"
toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application
toWaiApp a =
return $ gzip
$ jsonp
$ cleanPathRel (B.pack $ approot a)
$ toWaiApp' a
toWaiApp' :: (Yesod y, YesodSite y)
=> y
-> [String]
-> W.Request
-> IO W.Response
toWaiApp' y segments env = do
key' <- encryptKey y
now <- getCurrentTime
let getExpires m = fromIntegral (m * 60) `addUTCTime` now
let exp' = getExpires $ clientSessionDuration y
let host = W.remoteHost env
let session' = fromMaybe [] $ do
raw <- lookup "Cookie" $ W.requestHeaders env
val <- lookup (B.pack sessionName) $ parseCookies raw
decodeSession key' now host val
let site = getSite
method = B.unpack $ W.requestMethod env
types = httpAccept env
pathSegments = filter (not . null) segments
eurl = parsePathSegments site pathSegments
render u = fromMaybe
(fullRender (approot y) (formatPathSegments site) u)
(urlRenderOverride y u)
rr <- parseWaiRequest env session'
let h = do
onRequest
case eurl of
Left _ -> errorHandler NotFound
Right url -> do
ar <- isAuthorized url
case ar of
Authorized -> return ()
AuthenticationRequired ->
case authRoute y of
Nothing ->
permissionDenied "Authentication required"
Just url' -> do
setUltDest'
redirect RedirectTemporary url'
Unauthorized s -> permissionDenied s
case handleSite site render url method of
Nothing -> errorHandler $ BadMethod method
Just h' -> h'
let eurl' = either (const Nothing) Just eurl
let eh er = runHandler (errorHandler er) render eurl' id y id
let ya = runHandler h render eurl' id y id
(s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types
let sessionVal = encodeSession key' exp' host sessionFinal
let hs' = AddCookie (clientSessionDuration y) sessionName
(S.toString sessionVal)
: hs
hs'' = map (headerToPair getExpires) hs'
hs''' = ("Content-Type", S.fromString ct) : hs''
return $ W.Response s hs''' c
fullRender :: String
-> (url -> [String])
-> url
-> String
fullRender ar render route =
ar ++ '/' : encodePathInfo (fixSegs $ render route)
httpAccept :: W.Request -> [ContentType]
httpAccept = map B.unpack
. parseHttpAccept
. fromMaybe B.empty
. lookup "Accept"
. W.requestHeaders
basicHandler :: (Yesod y, YesodSite y)
=> Int
-> y
-> IO ()
basicHandler port y = basicHandler' port (Just "localhost") y
basicHandler' :: (Yesod y, YesodSite y)
=> Int
-> Maybe String
-> y
-> IO ()
basicHandler' port mhost y = do
app <- toWaiApp y
vars <- getEnvironment
case lookup "PATH_INFO" vars of
Nothing -> do
case mhost of
Nothing -> return ()
Just h -> putStrLn $ concat
["http://", h, ":", show port, "/"]
SS.run port app
Just _ -> CGI.run app
fixSegs :: [String] -> [String]
fixSegs [] = []
fixSegs [x]
| any (== '.') x = [x]
| otherwise = [x, ""]
fixSegs (x:xs) = x : fixSegs xs
parseWaiRequest :: W.Request
-> [(String, String)]
-> IO Request
parseWaiRequest env session' = do
let gets' = map (S.toString *** S.toString)
$ parseQueryString $ W.queryString env
let reqCookie = fromMaybe B.empty $ lookup "Cookie"
$ W.requestHeaders env
cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie
acceptLang = lookup "Accept-Language" $ W.requestHeaders env
langs = map S.toString $ maybe [] parseHttpAccept acceptLang
langs' = case lookup langKey session' of
Nothing -> langs
Just x -> x : langs
langs'' = case lookup langKey cookies' of
Nothing -> langs'
Just x -> x : langs'
langs''' = case lookup langKey gets' of
Nothing -> langs''
Just x -> x : langs''
rbthunk <- iothunk $ rbHelper env
return $ Request gets' cookies' session' rbthunk env langs'''
rbHelper :: W.Request -> IO RequestBodyContents
rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where
fix1 = map (S.toString *** S.toString)
fix2 (x, NWP.FileInfo a b c) =
(S.toString x, FileInfo (S.toString a) (S.toString b) c)
iothunk :: IO a -> IO (IO a)
iothunk = fmap go . newMVar . Left where
go :: MVar (Either (IO a) a) -> IO a
go mvar = modifyMVar mvar go'
go' :: Either (IO a) a -> IO (Either (IO a) a, a)
go' (Right val) = return (Right val, val)
go' (Left comp) = do
val <- comp
return (Right val, val)
headerToPair :: (Int -> UTCTime)
-> Header
-> (W.ResponseHeader, B.ByteString)
headerToPair getExpires (AddCookie minutes key value) =
let expires = getExpires minutes
in ("Set-Cookie", S.fromString
$ key ++ "=" ++ value ++"; path=/; expires="
++ formatW3 expires)
headerToPair _ (DeleteCookie key) =
("Set-Cookie", S.fromString $
key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
headerToPair _ (Header key value) =
(fromString key, S.fromString value)
encodeSession :: CS.Key
-> UTCTime
-> B.ByteString
-> [(String, String)]
-> B.ByteString
encodeSession key expire rhost session' =
encrypt key $ encode $ SessionCookie expire rhost session'
decodeSession :: CS.Key
-> UTCTime
-> B.ByteString
-> B.ByteString
-> Maybe [(String, String)]
decodeSession key now rhost encrypted = do
decrypted <- decrypt key encrypted
SessionCookie expire rhost' session' <-
either (const Nothing) Just $ decode decrypted
guard $ expire > now
guard $ rhost' == rhost
return session'
data SessionCookie = SessionCookie UTCTime B.ByteString [(String, String)]
deriving (Show, Read)
instance Serialize SessionCookie where
put (SessionCookie a b c) = putTime a >> put b >> put c
get = do
a <- getTime
b <- Ser.get
c <- Ser.get
return $ SessionCookie a b c
putTime :: Putter UTCTime
putTime t@(UTCTime d _) = do
put $ toModifiedJulianDay d
let ndt = diffUTCTime t $ UTCTime d 0
put $ toRational ndt
getTime :: Get UTCTime
getTime = do
d <- Ser.get
ndt <- Ser.get
return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0
#if TEST
testSuite :: Test
testSuite = testGroup "Yesod.Dispatch"
[ testProperty "encode/decode session" propEncDecSession
, testProperty "get/put time" propGetPutTime
]
propEncDecSession :: [(String, String)] -> Bool
propEncDecSession session' = unsafePerformIO $ do
key <- getDefaultKey
now <- getCurrentTime
let expire = addUTCTime 1 now
let rhost = B.pack "some host"
let val = encodeSession key expire rhost session'
return $ Just session' == decodeSession key now rhost val
propGetPutTime :: UTCTime -> Bool
propGetPutTime t = Right t == runGet getTime (runPut $ putTime t)
instance Arbitrary UTCTime where
arbitrary = do
a <- arbitrary
b <- arbitrary
return $ addUTCTime (fromRational b)
$ UTCTime (ModifiedJulianDay a) 0
#endif