Unified some datatypes
This commit is contained in:
Michael Snoyman
parent
4ece5fafd9
commit
7e2338aaa1
@ -12,7 +12,6 @@ import Control.Exception (SomeException, fromException,
|
||||
import Control.Exception.Lifted (catch)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Logger (LogLevel, LogSource)
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as S
|
||||
@ -30,12 +29,10 @@ import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Language.Haskell.TH.Syntax (Loc)
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Network.Wai
|
||||
import Prelude hiding (catch)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import System.Log.FastLogger (LogStr)
|
||||
import System.Log.FastLogger (Logger)
|
||||
import System.Random (newStdGen)
|
||||
import Web.Cookie (renderSetCookie)
|
||||
@ -83,30 +80,20 @@ headerToPair (Header key value) = (CI.mk key, value)
|
||||
|
||||
localNoCurrent :: GHandler s m a -> GHandler s m a
|
||||
localNoCurrent =
|
||||
local (\hd -> hd { handlerRoute = Nothing })
|
||||
local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheRoute = Nothing }})
|
||||
|
||||
local :: (HandlerData sub' master' -> HandlerData sub master)
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master' a
|
||||
local f (GHandler x) = GHandler $ \r -> x $ f r
|
||||
|
||||
data RunHandlerEnv sub master = RunHandlerEnv -- FIXME merge with YesodRunnerEnv? Or HandlerData
|
||||
{ rheRender :: !(Route master -> [(Text, Text)] -> Text)
|
||||
, rheRoute :: !(Maybe (Route sub))
|
||||
, rheToMaster :: !(Route sub -> Route master)
|
||||
, rheMaster :: !master
|
||||
, rheSub :: !sub
|
||||
, rheUpload :: !(RequestBodyLength -> FileUpload)
|
||||
, rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
|
||||
}
|
||||
|
||||
-- | Function used internally by Yesod in the process of converting a
|
||||
-- 'GHandler' into an 'Application'. Should not be needed by users.
|
||||
runHandler :: HasReps c
|
||||
=> RunHandlerEnv sub master
|
||||
-> GHandler sub master c
|
||||
-> YesodApp
|
||||
runHandler RunHandlerEnv {..} handler yreq = do
|
||||
runHandler rhe@RunHandlerEnv {..} handler yreq = do
|
||||
let toErrorHandler e =
|
||||
case fromException e of
|
||||
Just (HCError x) -> x
|
||||
@ -120,14 +107,8 @@ runHandler RunHandlerEnv {..} handler yreq = do
|
||||
}
|
||||
let hd = HandlerData
|
||||
{ handlerRequest = yreq
|
||||
, handlerSub = rheSub
|
||||
, handlerMaster = rheMaster
|
||||
, handlerRoute = rheRoute
|
||||
, handlerRender = rheRender
|
||||
, handlerToMaster = rheToMaster
|
||||
, handlerState = istate
|
||||
, handlerUpload = rheUpload
|
||||
, handlerLog = rheLog
|
||||
, handlerEnv = rhe
|
||||
, handlerState = istate
|
||||
}
|
||||
contents' <- catch (fmap Right $ unGHandler handler hd)
|
||||
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
|
||||
@ -290,15 +271,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
|
||||
I.readIORef ret
|
||||
{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
|
||||
|
||||
data YesodRunnerEnv sub master = YesodRunnerEnv
|
||||
{ yreLogger :: !Logger
|
||||
, yreMaster :: !master
|
||||
, yreSub :: !sub
|
||||
, yreRoute :: !(Maybe (Route sub))
|
||||
, yreToMaster :: !(Route sub -> Route master)
|
||||
, yreSessionBackend :: !(Maybe (SessionBackend master))
|
||||
}
|
||||
|
||||
defaultYesodRunner :: Yesod master
|
||||
=> YesodRunnerEnv sub master
|
||||
-> GHandler sub master ChooseRep
|
||||
@ -410,9 +382,11 @@ handlerSubDataMaybe :: (Route sub -> Route master)
|
||||
-> HandlerData oldSub master
|
||||
-> HandlerData sub master
|
||||
handlerSubDataMaybe tm ts route hd = hd
|
||||
{ handlerSub = ts $ handlerMaster hd
|
||||
, handlerToMaster = tm
|
||||
, handlerRoute = route
|
||||
{ handlerEnv = (handlerEnv hd)
|
||||
{ rheSub = ts $ rheMaster $ handlerEnv hd
|
||||
, rheToMaster = tm
|
||||
, rheRoute = route
|
||||
}
|
||||
}
|
||||
|
||||
resolveApproot :: Yesod master => master -> Request -> ResolvedApproot
|
||||
|
||||
@ -44,7 +44,7 @@ import Network.Wai (FilePart,
|
||||
RequestBodyLength)
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.Wai.Parse as NWP
|
||||
import System.Log.FastLogger (LogStr, toLogStr)
|
||||
import System.Log.FastLogger (LogStr, toLogStr, Logger)
|
||||
import Text.Blaze.Html (Html)
|
||||
import Text.Hamlet (HtmlUrl)
|
||||
import Text.Julius (JavascriptUrl)
|
||||
@ -114,8 +114,8 @@ data YesodRequest = YesodRequest
|
||||
-- | An augmented WAI 'W.Response'. This can either be a standard @Response@,
|
||||
-- or a higher-level data structure which Yesod will turn into a @Response@.
|
||||
data YesodResponse
|
||||
= YRWai W.Response
|
||||
| YRPlain H.Status [Header] ContentType Content SessionMap
|
||||
= YRWai !W.Response
|
||||
| YRPlain !H.Status ![Header] !ContentType !Content !SessionMap
|
||||
|
||||
-- | A tuple containing both the POST parameters and submitted files.
|
||||
type RequestBodyContents =
|
||||
@ -124,15 +124,15 @@ type RequestBodyContents =
|
||||
)
|
||||
|
||||
data FileInfo = FileInfo
|
||||
{ fileName :: Text
|
||||
, fileContentType :: Text
|
||||
, fileSource :: Source (ResourceT IO) ByteString
|
||||
, fileMove :: FilePath -> IO ()
|
||||
{ fileName :: !Text
|
||||
, fileContentType :: !Text
|
||||
, fileSource :: !(Source (ResourceT IO) ByteString)
|
||||
, fileMove :: !(FilePath -> IO ())
|
||||
}
|
||||
|
||||
data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString)
|
||||
| FileUploadDisk (NWP.BackEnd FilePath)
|
||||
| FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString))
|
||||
data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
|
||||
| FileUploadDisk !(NWP.BackEnd FilePath)
|
||||
| FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
|
||||
|
||||
-- | How to determine the root of the application for constructing URLs.
|
||||
--
|
||||
@ -140,9 +140,9 @@ data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString)
|
||||
-- the major version number. As a result, you should /not/ pattern match on
|
||||
-- @Approot@ values.
|
||||
data Approot master = ApprootRelative -- ^ No application root.
|
||||
| ApprootStatic Text
|
||||
| ApprootMaster (master -> Text)
|
||||
| ApprootRequest (master -> W.Request -> Text)
|
||||
| ApprootStatic !Text
|
||||
| ApprootMaster !(master -> Text)
|
||||
| ApprootRequest !(master -> W.Request -> Text)
|
||||
|
||||
type ResolvedApproot = Text
|
||||
|
||||
@ -169,16 +169,29 @@ type Texts = [Text]
|
||||
-- | Wrap up a normal WAI application as a Yesod subsite.
|
||||
newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
|
||||
|
||||
data RunHandlerEnv sub master = RunHandlerEnv
|
||||
{ rheRender :: !(Route master -> [(Text, Text)] -> Text)
|
||||
, rheRoute :: !(Maybe (Route sub))
|
||||
, rheToMaster :: !(Route sub -> Route master)
|
||||
, rheMaster :: !master
|
||||
, rheSub :: !sub
|
||||
, rheUpload :: !(RequestBodyLength -> FileUpload)
|
||||
, rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
|
||||
}
|
||||
|
||||
data HandlerData sub master = HandlerData
|
||||
{ handlerRequest :: YesodRequest
|
||||
, handlerSub :: sub
|
||||
, handlerMaster :: master
|
||||
, handlerRoute :: Maybe (Route sub)
|
||||
, handlerRender :: Route master -> [(Text, Text)] -> Text
|
||||
, handlerToMaster :: Route sub -> Route master
|
||||
, handlerState :: IORef GHState
|
||||
, handlerUpload :: RequestBodyLength -> FileUpload
|
||||
, handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
|
||||
{ handlerRequest :: !YesodRequest
|
||||
, handlerEnv :: !(RunHandlerEnv sub master)
|
||||
, handlerState :: !(IORef GHState)
|
||||
}
|
||||
|
||||
data YesodRunnerEnv sub master = YesodRunnerEnv
|
||||
{ yreLogger :: !Logger
|
||||
, yreMaster :: !master
|
||||
, yreSub :: !sub
|
||||
, yreRoute :: !(Maybe (Route sub))
|
||||
, yreToMaster :: !(Route sub -> Route master)
|
||||
, yreSessionBackend :: !(Maybe (SessionBackend master))
|
||||
}
|
||||
|
||||
-- | A generic handler monad, which can have a different subsite and master
|
||||
@ -407,7 +420,7 @@ instance MonadResource (GHandler sub master) where
|
||||
|
||||
instance MonadLogger (GHandler sub master) where
|
||||
monadLoggerLog a b c d = GHandler $ \hd ->
|
||||
liftIO $ handlerLog hd a b c (toLogStr d)
|
||||
liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
|
||||
|
||||
instance Exception e => Failure e (GHandler sub master) where
|
||||
failure = liftIO . throwIO
|
||||
|
||||
@ -199,7 +199,7 @@ hcError = liftIO . throwIO . HCError
|
||||
runRequestBody :: GHandler s m RequestBodyContents
|
||||
runRequestBody = do
|
||||
hd <- ask
|
||||
let getUpload = handlerUpload hd
|
||||
let getUpload = rheUpload $ handlerEnv hd
|
||||
len = W.requestBodyLength
|
||||
$ reqWaiRequest
|
||||
$ handlerRequest hd
|
||||
@ -241,32 +241,32 @@ rbHelper' backend mkFI req =
|
||||
|
||||
-- | Get the sub application argument.
|
||||
getYesodSub :: GHandler sub master sub
|
||||
getYesodSub = handlerSub `liftM` ask
|
||||
getYesodSub = (rheSub . handlerEnv) `liftM` ask
|
||||
|
||||
-- | Get the master site appliation argument.
|
||||
getYesod :: GHandler sub master master
|
||||
getYesod = handlerMaster `liftM` ask
|
||||
getYesod = (rheMaster . handlerEnv) `liftM` ask
|
||||
|
||||
-- | Get the URL rendering function.
|
||||
getUrlRender :: GHandler sub master (Route master -> Text)
|
||||
getUrlRender = do
|
||||
x <- handlerRender `liftM` ask
|
||||
x <- (rheRender . handlerEnv) `liftM` ask
|
||||
return $ flip x []
|
||||
|
||||
-- | The URL rendering function with query-string parameters.
|
||||
getUrlRenderParams
|
||||
:: GHandler sub master (Route master -> [(Text, Text)] -> Text)
|
||||
getUrlRenderParams = handlerRender `liftM` ask
|
||||
getUrlRenderParams = (rheRender . handlerEnv) `liftM` ask
|
||||
|
||||
-- | Get the route requested by the user. If this is a 404 response- where the
|
||||
-- user requested an invalid route- this function will return 'Nothing'.
|
||||
getCurrentRoute :: GHandler sub master (Maybe (Route sub))
|
||||
getCurrentRoute = handlerRoute `liftM` ask
|
||||
getCurrentRoute = (rheRoute . handlerEnv) `liftM` ask
|
||||
|
||||
-- | Get the function to promote a route for a subsite to a route for the
|
||||
-- master site.
|
||||
getRouteToMaster :: GHandler sub master (Route sub -> Route master)
|
||||
getRouteToMaster = handlerToMaster `liftM` ask
|
||||
getRouteToMaster = (rheToMaster . handlerEnv) `liftM` ask
|
||||
|
||||
|
||||
-- | Returns a function that runs 'GHandler' actions inside @IO@.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user