Yesod.Core.Types created, but it's a mess
This commit is contained in:
Michael Snoyman
parent
20091656aa
commit
98613278d4
@ -63,8 +63,6 @@ import Data.Monoid (mempty)
|
||||
|
||||
import Text.Hamlet (Html)
|
||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
||||
import Data.String (IsString (fromString))
|
||||
import Network.Wai (FilePart)
|
||||
import Data.Conduit (Source, ResourceT, Flush (Chunk), ResumableSource, mapOutput)
|
||||
import Data.Conduit.Internal (ResumableSource (ResumableSource))
|
||||
|
||||
@ -72,19 +70,12 @@ import qualified Data.Aeson as J
|
||||
import Data.Aeson.Encode (fromValue)
|
||||
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
|
||||
import Data.Text.Lazy.Builder (toLazyText)
|
||||
|
||||
data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length.
|
||||
| ContentSource !(Source (ResourceT IO) (Flush Builder))
|
||||
| ContentFile !FilePath !(Maybe FilePart)
|
||||
| ContentDontEvaluate !Content
|
||||
import Yesod.Core.Types
|
||||
|
||||
-- | Zero-length enumerator.
|
||||
emptyContent :: Content
|
||||
emptyContent = ContentBuilder mempty $ Just 0
|
||||
|
||||
instance IsString Content where
|
||||
fromString = toContent
|
||||
|
||||
-- | Anything which can be converted into 'Content'. Most of the time, you will
|
||||
-- want to use the 'ContentBuilder' constructor. An easier approach will be to use
|
||||
-- a pre-defined 'toContent' function, such as converting your data into a lazy
|
||||
@ -122,12 +113,6 @@ instance ToFlushBuilder Builder where toFlushBuilder = Chunk
|
||||
instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString
|
||||
instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString
|
||||
|
||||
-- | A function which gives targetted representations of content based on the
|
||||
-- content-types the user accepts.
|
||||
type ChooseRep =
|
||||
[ContentType] -- ^ list of content-types user accepts, ordered by preference
|
||||
-> IO (ContentType, Content)
|
||||
|
||||
-- | Any type which can be converted to representations.
|
||||
class HasReps a where
|
||||
chooseRep :: a -> ChooseRep
|
||||
@ -170,27 +155,20 @@ instance HasReps [(ContentType, Content)] where
|
||||
where
|
||||
go = simpleContentType
|
||||
|
||||
newtype RepHtml = RepHtml Content
|
||||
instance HasReps RepHtml where
|
||||
chooseRep (RepHtml c) _ = return (typeHtml, c)
|
||||
newtype RepJson = RepJson Content
|
||||
instance HasReps RepJson where
|
||||
chooseRep (RepJson c) _ = return (typeJson, c)
|
||||
data RepHtmlJson = RepHtmlJson Content Content
|
||||
instance HasReps RepHtmlJson where
|
||||
chooseRep (RepHtmlJson html json) = chooseRep
|
||||
[ (typeHtml, html)
|
||||
, (typeJson, json)
|
||||
]
|
||||
newtype RepPlain = RepPlain Content
|
||||
instance HasReps RepPlain where
|
||||
chooseRep (RepPlain c) _ = return (typePlain, c)
|
||||
newtype RepXml = RepXml Content
|
||||
instance HasReps RepXml where
|
||||
chooseRep (RepXml c) _ = return (typeXml, c)
|
||||
|
||||
type ContentType = B.ByteString -- FIXME Text?
|
||||
|
||||
typeHtml :: ContentType
|
||||
typeHtml = "text/html; charset=utf-8"
|
||||
|
||||
@ -256,12 +234,6 @@ formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
|
||||
formatRFC822 :: UTCTime -> T.Text
|
||||
formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
|
||||
|
||||
-- | Prevents a response body from being fully evaluated before sending the
|
||||
-- request.
|
||||
--
|
||||
-- Since 1.1.0
|
||||
newtype DontFullyEvaluate a = DontFullyEvaluate a
|
||||
|
||||
instance HasReps a => HasReps (DontFullyEvaluate a) where
|
||||
chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a
|
||||
|
||||
|
||||
@ -53,8 +53,8 @@ module Yesod.Core
|
||||
, module Yesod.Handler
|
||||
, module Yesod.Request
|
||||
, module Yesod.Widget
|
||||
, module Yesod.Message
|
||||
, module Yesod.Core.Json
|
||||
, module Text.Shakespeare.I18N
|
||||
) where
|
||||
|
||||
import Yesod.Internal.Core
|
||||
@ -64,8 +64,8 @@ import Yesod.Dispatch
|
||||
import Yesod.Handler
|
||||
import Yesod.Request
|
||||
import Yesod.Widget
|
||||
import Yesod.Message
|
||||
import Yesod.Core.Json
|
||||
import Text.Shakespeare.I18N
|
||||
|
||||
import Control.Monad.Logger
|
||||
|
||||
|
||||
@ -24,7 +24,7 @@ module Yesod.Core.Json
|
||||
import Yesod.Handler (GHandler, waiRequest, lift, invalidArgs, redirect)
|
||||
import Yesod.Content
|
||||
( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml)
|
||||
, RepJson (RepJson), Content (ContentBuilder)
|
||||
, RepJson (RepJson)
|
||||
)
|
||||
import Yesod.Internal.Core (defaultLayout, Yesod)
|
||||
import Yesod.Widget (GWidget)
|
||||
@ -35,16 +35,9 @@ import Control.Monad (join)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Parser as JP
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson.Encode as JE
|
||||
import Data.Aeson.Encode (fromValue)
|
||||
import Data.Conduit.Attoparsec (sinkParser)
|
||||
import Data.Text (Text, pack)
|
||||
import qualified Data.Vector as V
|
||||
import Text.Julius (ToJavascript (..))
|
||||
import Data.Text.Lazy.Builder (fromLazyText)
|
||||
import Data.Text.Lazy.Encoding (decodeUtf8)
|
||||
import Data.Text.Lazy.Builder (toLazyText)
|
||||
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
|
||||
import Data.Conduit
|
||||
import Network.Wai (requestBody, requestHeaders)
|
||||
import Network.Wai.Parse (parseHttpAccept)
|
||||
|
||||
29
yesod-core/Yesod/Core/Time.hs
Normal file
29
yesod-core/Yesod/Core/Time.hs
Normal file
@ -0,0 +1,29 @@
|
||||
module Yesod.Core.Time
|
||||
( putTime
|
||||
, getTime
|
||||
) where
|
||||
|
||||
import Data.Int (Int64)
|
||||
import Data.Serialize (Get, Put, Serialize (..))
|
||||
import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay),
|
||||
DiffTime, UTCTime (..))
|
||||
|
||||
putTime :: UTCTime -> Put
|
||||
putTime (UTCTime d t) =
|
||||
let d' = fromInteger $ toModifiedJulianDay d
|
||||
t' = fromIntegral $ fromEnum (t / diffTimeScale)
|
||||
in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')
|
||||
|
||||
getTime :: Get UTCTime
|
||||
getTime = do
|
||||
val <- get
|
||||
let (d, t) = val `divMod` posixDayLength_int64
|
||||
d' = ModifiedJulianDay $! fromIntegral d
|
||||
t' = fromIntegral t
|
||||
d' `seq` t' `seq` return (UTCTime d' t')
|
||||
|
||||
posixDayLength_int64 :: Int64
|
||||
posixDayLength_int64 = 86400
|
||||
|
||||
diffTimeScale :: DiffTime
|
||||
diffTimeScale = 1e12
|
||||
15
yesod-core/Yesod/Core/Trans/Class.hs
Normal file
15
yesod-core/Yesod/Core/Trans/Class.hs
Normal file
@ -0,0 +1,15 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Yesod.Core.Trans.Class (MonadLift (..)) where
|
||||
|
||||
import Control.Monad.Trans.Class
|
||||
|
||||
-- | The standard @MonadTrans@ class only allows lifting for monad
|
||||
-- transformers. While @GHandler@ and @GWidget@ should allow lifting, their
|
||||
-- types do not express that they actually are transformers. This replacement
|
||||
-- class accounts for this.
|
||||
class MonadLift base m | m -> base where
|
||||
lift :: base a -> m a
|
||||
instance (Monad m, MonadTrans t) => MonadLift m (t m) where
|
||||
lift = Control.Monad.Trans.Class.lift
|
||||
417
yesod-core/Yesod/Core/Types.hs
Normal file
417
yesod-core/Yesod/Core/Types.hs
Normal file
@ -0,0 +1,417 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Yesod.Core.Types where
|
||||
|
||||
import qualified Blaze.ByteString.Builder as BBuilder
|
||||
import qualified Blaze.ByteString.Builder.Char.Utf8
|
||||
import Control.Applicative (Applicative (..))
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Arrow (first)
|
||||
import Control.Exception (Exception, throwIO)
|
||||
import Control.Failure (Failure (..))
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.Base (MonadBase (liftBase))
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Logger (LogLevel, LogSource,
|
||||
MonadLogger (..))
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Resource (MonadResource (..))
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Conduit (Flush, MonadThrow (..),
|
||||
MonadUnsafeIO (..),
|
||||
ResourceT, Source)
|
||||
import Data.IntMap (IntMap)
|
||||
import Data.IORef (IORef)
|
||||
import Data.Map (Map, unionWith)
|
||||
import Data.Monoid (Any, Endo (..), Last (..),
|
||||
Monoid (..))
|
||||
import Data.Serialize (Serialize (..),
|
||||
putByteString)
|
||||
import Data.String (IsString (fromString))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy.Builder as TBuilder
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Typeable (Typeable)
|
||||
import Language.Haskell.TH.Syntax (Loc)
|
||||
import qualified Network.HTTP.Types as H
|
||||
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 Text.Blaze.Html (Html)
|
||||
import Text.Hamlet (HtmlUrl)
|
||||
import Text.Julius (JavascriptUrl)
|
||||
import Web.Cookie (SetCookie)
|
||||
import Yesod.Core.Time (getTime, putTime)
|
||||
import Yesod.Core.Trans.Class (MonadLift (..))
|
||||
import Yesod.Routes.Class (RenderRoute (..))
|
||||
|
||||
-- Sessions
|
||||
type BackendSession = [(Text, ByteString)]
|
||||
|
||||
type SaveSession = BackendSession -- ^ The session contents after running the handler
|
||||
-> IO [Header]
|
||||
|
||||
newtype SessionBackend master = SessionBackend
|
||||
{ sbLoadSession :: master
|
||||
-> W.Request
|
||||
-> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session
|
||||
}
|
||||
|
||||
data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)]
|
||||
deriving (Show, Read)
|
||||
instance Serialize SessionCookie where
|
||||
put (SessionCookie a b c) = do
|
||||
either putTime putByteString a
|
||||
put b
|
||||
put (map (first T.unpack) c)
|
||||
|
||||
get = do
|
||||
a <- getTime
|
||||
b <- get
|
||||
c <- map (first T.pack) <$> get
|
||||
return $ SessionCookie (Left a) b c
|
||||
|
||||
data ClientSessionDateCache =
|
||||
ClientSessionDateCache {
|
||||
csdcNow :: !UTCTime
|
||||
, csdcExpires :: !UTCTime
|
||||
, csdcExpiresSerialized :: !ByteString
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | The parsed request information.
|
||||
data Request = Request
|
||||
{ reqGetParams :: [(Text, Text)]
|
||||
, reqCookies :: [(Text, Text)]
|
||||
, reqWaiRequest :: W.Request
|
||||
-- | Languages which the client supports.
|
||||
, reqLangs :: [Text]
|
||||
-- | A random, session-specific token used to prevent CSRF attacks.
|
||||
, reqToken :: Maybe Text
|
||||
}
|
||||
|
||||
-- | A tuple containing both the POST parameters and submitted files.
|
||||
type RequestBodyContents =
|
||||
( [(Text, Text)]
|
||||
, [(Text, FileInfo)]
|
||||
)
|
||||
|
||||
data FileInfo = FileInfo
|
||||
{ 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))
|
||||
|
||||
-- | How to determine the root of the application for constructing URLs.
|
||||
--
|
||||
-- Note that future versions of Yesod may add new constructors without bumping
|
||||
-- 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)
|
||||
|
||||
type ResolvedApproot = Text
|
||||
|
||||
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
|
||||
deriving (Eq, Show, Read)
|
||||
|
||||
data ScriptLoadPosition master
|
||||
= BottomOfBody
|
||||
| BottomOfHeadBlocking
|
||||
| BottomOfHeadAsync (BottomOfHeadAsync master)
|
||||
|
||||
type BottomOfHeadAsync master
|
||||
= [Text] -- ^ urls to load asynchronously
|
||||
-> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion
|
||||
-> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>
|
||||
|
||||
newtype Cache = Cache (IntMap Any)
|
||||
deriving Monoid
|
||||
|
||||
newtype CacheKey a = CacheKey Int
|
||||
|
||||
type Texts = [Text]
|
||||
|
||||
-- | Wrap up a normal WAI application as a Yesod subsite.
|
||||
newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
|
||||
|
||||
data HandlerData sub master = HandlerData
|
||||
{ handlerRequest :: Request
|
||||
, 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 ()
|
||||
}
|
||||
|
||||
-- | A generic handler monad, which can have a different subsite and master
|
||||
-- site. We define a newtype for better error message.
|
||||
newtype GHandler sub master a = GHandler
|
||||
{ unGHandler :: HandlerData sub master -> ResourceT IO a
|
||||
}
|
||||
|
||||
data GHState = GHState
|
||||
{ ghsSession :: SessionMap
|
||||
, ghsRBC :: Maybe RequestBodyContents
|
||||
, ghsIdent :: Int
|
||||
, ghsCache :: Cache
|
||||
, ghsHeaders :: Endo [Header]
|
||||
}
|
||||
|
||||
type SessionMap = Map Text ByteString
|
||||
|
||||
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
|
||||
-- features needed by Yesod. Users should never need to use this directly, as
|
||||
-- the 'GHandler' monad and template haskell code should hide it away.
|
||||
newtype YesodApp = YesodApp
|
||||
{ unYesodApp
|
||||
:: (ErrorResponse -> YesodApp)
|
||||
-> Request
|
||||
-> [ContentType]
|
||||
-> SessionMap
|
||||
-> ResourceT IO YesodAppResult
|
||||
}
|
||||
|
||||
data YesodAppResult
|
||||
= YARWai W.Response
|
||||
| YARPlain H.Status [Header] ContentType Content SessionMap
|
||||
|
||||
-- | A generic widget, allowing specification of both the subsite and master
|
||||
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
|
||||
-- better error messages.
|
||||
newtype GWidget sub master a = GWidget
|
||||
{ unGWidget :: GHandler sub master (a, GWData (Route master))
|
||||
}
|
||||
|
||||
instance (a ~ ()) => Monoid (GWidget sub master a) where
|
||||
mempty = return ()
|
||||
mappend x y = x >> y
|
||||
|
||||
type RY master = Route master -> [(Text, Text)] -> Text
|
||||
|
||||
-- | Newtype wrapper allowing injection of arbitrary content into CSS.
|
||||
--
|
||||
-- Usage:
|
||||
--
|
||||
-- > toWidget $ CssBuilder "p { color: red }"
|
||||
--
|
||||
-- Since: 1.1.3
|
||||
newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
|
||||
|
||||
-- | Content for a web page. By providing this datatype, we can easily create
|
||||
-- generic site templates, which would have the type signature:
|
||||
--
|
||||
-- > PageContent url -> HtmlUrl url
|
||||
data PageContent url = PageContent
|
||||
{ pageTitle :: Html
|
||||
, pageHead :: HtmlUrl url
|
||||
, pageBody :: HtmlUrl url
|
||||
}
|
||||
|
||||
data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length.
|
||||
| ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder))
|
||||
| ContentFile !FilePath !(Maybe FilePart)
|
||||
| ContentDontEvaluate !Content
|
||||
|
||||
-- | A function which gives targetted representations of content based on the
|
||||
-- content-types the user accepts.
|
||||
type ChooseRep =
|
||||
[ContentType] -- ^ list of content-types user accepts, ordered by preference
|
||||
-> IO (ContentType, Content)
|
||||
|
||||
newtype RepHtml = RepHtml Content
|
||||
newtype RepJson = RepJson Content
|
||||
data RepHtmlJson = RepHtmlJson Content Content
|
||||
newtype RepPlain = RepPlain Content
|
||||
newtype RepXml = RepXml Content
|
||||
|
||||
type ContentType = ByteString -- FIXME Text?
|
||||
|
||||
-- | Prevents a response body from being fully evaluated before sending the
|
||||
-- request.
|
||||
--
|
||||
-- Since 1.1.0
|
||||
newtype DontFullyEvaluate a = DontFullyEvaluate a
|
||||
|
||||
-- | Responses to indicate some form of an error occurred. These are different
|
||||
-- from 'SpecialResponse' in that they allow for custom error pages.
|
||||
data ErrorResponse =
|
||||
NotFound
|
||||
| InternalError Text
|
||||
| InvalidArgs [Text]
|
||||
| PermissionDenied Text
|
||||
| BadMethod H.Method
|
||||
deriving (Show, Eq, Typeable)
|
||||
|
||||
----- header stuff
|
||||
-- | Headers to be added to a 'Result'.
|
||||
data Header =
|
||||
AddCookie SetCookie
|
||||
| DeleteCookie ByteString ByteString
|
||||
| Header ByteString ByteString
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Location url = Local url | Remote Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
newtype UniqueList x = UniqueList ([x] -> [x])
|
||||
|
||||
data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
newtype Title = Title { unTitle :: Html }
|
||||
|
||||
newtype Head url = Head (HtmlUrl url)
|
||||
deriving Monoid
|
||||
newtype Body url = Body (HtmlUrl url)
|
||||
deriving Monoid
|
||||
|
||||
type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
|
||||
|
||||
data GWData a = GWData
|
||||
{ gwdBody :: !(Body a)
|
||||
, gwdTitle :: !(Last Title)
|
||||
, gwdScripts :: !(UniqueList (Script a))
|
||||
, gwdStylesheets :: !(UniqueList (Stylesheet a))
|
||||
, gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
|
||||
, gwdJavascript :: !(Maybe (JavascriptUrl a))
|
||||
, gwdHead :: !(Head a)
|
||||
}
|
||||
instance Monoid (GWData a) where
|
||||
mempty = GWData mempty mempty mempty mempty mempty mempty mempty
|
||||
mappend (GWData a1 a2 a3 a4 a5 a6 a7)
|
||||
(GWData b1 b2 b3 b4 b5 b6 b7) = GWData
|
||||
(a1 `mappend` b1)
|
||||
(a2 `mappend` b2)
|
||||
(a3 `mappend` b3)
|
||||
(a4 `mappend` b4)
|
||||
(unionWith mappend a5 b5)
|
||||
(a6 `mappend` b6)
|
||||
(a7 `mappend` b7)
|
||||
|
||||
data HandlerContents =
|
||||
HCContent H.Status ChooseRep
|
||||
| HCError ErrorResponse
|
||||
| HCSendFile ContentType FilePath (Maybe FilePart)
|
||||
| HCRedirect H.Status Text
|
||||
| HCCreated Text
|
||||
| HCWai W.Response
|
||||
deriving Typeable
|
||||
|
||||
instance Show HandlerContents where
|
||||
show _ = "Cannot show a HandlerContents"
|
||||
instance Exception HandlerContents
|
||||
|
||||
-- Instances for GWidget
|
||||
instance Functor (GWidget sub master) where
|
||||
fmap f (GWidget x) = GWidget (fmap (first f) x)
|
||||
instance Applicative (GWidget sub master) where
|
||||
pure a = GWidget $ pure (a, mempty)
|
||||
GWidget f <*> GWidget v =
|
||||
GWidget $ k <$> f <*> v
|
||||
where
|
||||
k (a, wa) (b, wb) = (a b, wa `mappend` wb)
|
||||
instance Monad (GWidget sub master) where
|
||||
return = pure
|
||||
GWidget x >>= f = GWidget $ do
|
||||
(a, wa) <- x
|
||||
(b, wb) <- unGWidget (f a)
|
||||
return (b, wa `mappend` wb)
|
||||
instance MonadIO (GWidget sub master) where
|
||||
liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO
|
||||
instance MonadBase IO (GWidget sub master) where
|
||||
liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase
|
||||
instance MonadBaseControl IO (GWidget sub master) where
|
||||
data StM (GWidget sub master) a =
|
||||
StW (StM (GHandler sub master) (a, GWData (Route master)))
|
||||
liftBaseWith f = GWidget $ liftBaseWith $ \runInBase ->
|
||||
liftM (\x -> (x, mempty))
|
||||
(f $ liftM StW . runInBase . unGWidget)
|
||||
restoreM (StW base) = GWidget $ restoreM base
|
||||
|
||||
instance MonadUnsafeIO (GWidget sub master) where
|
||||
unsafeLiftIO = liftIO
|
||||
instance MonadThrow (GWidget sub master) where
|
||||
monadThrow = liftIO . throwIO
|
||||
instance MonadResource (GWidget sub master) where
|
||||
liftResourceT = lift . liftResourceT
|
||||
|
||||
instance MonadLogger (GWidget sub master) where
|
||||
monadLoggerLog a b c = lift . monadLoggerLog a b c
|
||||
|
||||
instance MonadLift (GHandler sub master) (GWidget sub master) where
|
||||
lift = GWidget . fmap (\x -> (x, mempty))
|
||||
|
||||
instance MonadLift (ResourceT IO) (GHandler sub master) where
|
||||
lift = GHandler . const
|
||||
|
||||
-- Instances for GHandler
|
||||
instance Functor (GHandler sub master) where
|
||||
fmap f (GHandler x) = GHandler $ \r -> fmap f (x r)
|
||||
instance Applicative (GHandler sub master) where
|
||||
pure = GHandler . const . pure
|
||||
GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r
|
||||
instance Monad (GHandler sub master) where
|
||||
return = pure
|
||||
GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r
|
||||
instance MonadIO (GHandler sub master) where
|
||||
liftIO = GHandler . const . lift
|
||||
instance MonadBase IO (GHandler sub master) where
|
||||
liftBase = GHandler . const . lift
|
||||
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
|
||||
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
|
||||
-- Instead, if you must fork a separate thread, you should use
|
||||
-- @resourceForkIO@.
|
||||
--
|
||||
-- Using fork usually leads to an exception that says
|
||||
-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
|
||||
-- after cleanup. Please contact the maintainers.\"
|
||||
instance MonadBaseControl IO (GHandler sub master) where
|
||||
data StM (GHandler sub master) a = StH (StM (ResourceT IO) a)
|
||||
liftBaseWith f = GHandler $ \reader ->
|
||||
liftBaseWith $ \runInBase ->
|
||||
f $ liftM StH . runInBase . (\(GHandler r) -> r reader)
|
||||
restoreM (StH base) = GHandler $ const $ restoreM base
|
||||
|
||||
instance MonadUnsafeIO (GHandler sub master) where
|
||||
unsafeLiftIO = liftIO
|
||||
instance MonadThrow (GHandler sub master) where
|
||||
monadThrow = liftIO . throwIO
|
||||
instance MonadResource (GHandler sub master) where
|
||||
liftResourceT = lift . liftResourceT
|
||||
|
||||
instance MonadLogger (GHandler sub master) where
|
||||
monadLoggerLog a b c d = GHandler $ \hd ->
|
||||
liftIO $ handlerLog hd a b c (toLogStr d)
|
||||
|
||||
instance Exception e => Failure e (GHandler sub master) where
|
||||
failure = liftIO . throwIO
|
||||
|
||||
instance Monoid (UniqueList x) where
|
||||
mempty = UniqueList id
|
||||
UniqueList x `mappend` UniqueList y = UniqueList $ x . y
|
||||
|
||||
instance IsString Content where
|
||||
fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString
|
||||
|
||||
instance RenderRoute WaiSubsite where
|
||||
data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]
|
||||
deriving (Show, Eq, Read, Ord)
|
||||
renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
|
||||
@ -33,7 +33,6 @@ import Control.Applicative ((<$>), (<*>))
|
||||
import Prelude hiding (exp)
|
||||
import Yesod.Internal.Core
|
||||
import Yesod.Handler hiding (lift)
|
||||
import Yesod.Widget (GWidget)
|
||||
|
||||
import Web.PathPieces
|
||||
import Language.Haskell.TH
|
||||
@ -56,8 +55,7 @@ import Yesod.Routes.TH
|
||||
import Yesod.Content (chooseRep)
|
||||
import Yesod.Routes.Parse
|
||||
import System.Log.FastLogger (Logger)
|
||||
|
||||
type Texts = [Text]
|
||||
import Yesod.Core.Types
|
||||
|
||||
-- | Generates URL datatype and site function for the given 'Resource's. This
|
||||
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
|
||||
@ -210,14 +208,3 @@ sendRedirect y segments' env =
|
||||
then dest
|
||||
else (dest `mappend`
|
||||
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
|
||||
|
||||
-- | Wrap up a normal WAI application as a Yesod subsite.
|
||||
newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
|
||||
|
||||
instance RenderRoute WaiSubsite where
|
||||
data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]
|
||||
deriving (Show, Eq, Read, Ord)
|
||||
renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
|
||||
|
||||
instance YesodDispatch WaiSubsite master where
|
||||
yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
|
||||
|
||||
@ -129,11 +129,8 @@ import Control.Exception hiding (Handler, catch, finally)
|
||||
import Control.Applicative
|
||||
|
||||
import Control.Monad (liftM)
|
||||
import Control.Failure (Failure (failure))
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class (MonadTrans)
|
||||
import qualified Control.Monad.Trans.Class
|
||||
|
||||
import System.IO
|
||||
import qualified Network.Wai as W
|
||||
@ -163,7 +160,7 @@ import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString)
|
||||
import Data.Text (Text)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
import Text.Shakespeare.I18N (RenderMessage (..))
|
||||
|
||||
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
||||
#define preEscapedText preEscapedToMarkup
|
||||
@ -172,30 +169,18 @@ import System.Log.FastLogger
|
||||
import Control.Monad.Logger
|
||||
|
||||
import qualified Yesod.Internal.Cache as Cache
|
||||
import Yesod.Internal.Cache (mkCacheKey, CacheKey)
|
||||
import Yesod.Internal.Cache (mkCacheKey)
|
||||
import qualified Data.IORef as I
|
||||
import Control.Exception.Lifted (catch)
|
||||
import Control.Monad.Trans.Control
|
||||
import Control.Monad.Trans.Resource
|
||||
import Control.Monad.Base
|
||||
import Yesod.Routes.Class
|
||||
import Language.Haskell.TH.Syntax (Loc)
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Trans.Class
|
||||
|
||||
class YesodSubRoute s y where
|
||||
fromSubRoute :: s -> y -> Route s -> Route y
|
||||
|
||||
data HandlerData sub master = HandlerData
|
||||
{ handlerRequest :: Request
|
||||
, handlerSub :: sub
|
||||
, handlerMaster :: master
|
||||
, handlerRoute :: Maybe (Route sub)
|
||||
, handlerRender :: Route master -> [(Text, Text)] -> Text
|
||||
, handlerToMaster :: Route sub -> Route master
|
||||
, handlerState :: I.IORef GHState
|
||||
, handlerUpload :: W.RequestBodyLength -> FileUpload
|
||||
, handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
|
||||
}
|
||||
|
||||
handlerSubData :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Route sub
|
||||
@ -270,38 +255,6 @@ toMasterHandlerMaybe :: (Route sub -> Route master)
|
||||
-> GHandler sub' master a
|
||||
toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)
|
||||
|
||||
-- | A generic handler monad, which can have a different subsite and master
|
||||
-- site. We define a newtype for better error message.
|
||||
newtype GHandler sub master a = GHandler
|
||||
{ unGHandler :: HandlerData sub master -> ResourceT IO a
|
||||
}
|
||||
|
||||
data GHState = GHState
|
||||
{ ghsSession :: SessionMap
|
||||
, ghsRBC :: Maybe RequestBodyContents
|
||||
, ghsIdent :: Int
|
||||
, ghsCache :: Cache.Cache
|
||||
, ghsHeaders :: Endo [Header]
|
||||
}
|
||||
|
||||
type SessionMap = Map.Map Text S.ByteString
|
||||
|
||||
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
|
||||
-- features needed by Yesod. Users should never need to use this directly, as
|
||||
-- the 'GHandler' monad and template haskell code should hide it away.
|
||||
newtype YesodApp = YesodApp
|
||||
{ unYesodApp
|
||||
:: (ErrorResponse -> YesodApp)
|
||||
-> Request
|
||||
-> [ContentType]
|
||||
-> SessionMap
|
||||
-> ResourceT IO YesodAppResult
|
||||
}
|
||||
|
||||
data YesodAppResult
|
||||
= YARWai W.Response
|
||||
| YARPlain H.Status [Header] ContentType Content SessionMap
|
||||
|
||||
getRequest :: GHandler s m Request
|
||||
getRequest = handlerRequest `liftM` ask
|
||||
|
||||
@ -1003,71 +956,3 @@ local :: (HandlerData sub' master' -> HandlerData sub master)
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master' a
|
||||
local f (GHandler x) = GHandler $ \r -> x $ f r
|
||||
|
||||
-- | The standard @MonadTrans@ class only allows lifting for monad
|
||||
-- transformers. While @GHandler@ and @GWidget@ should allow lifting, their
|
||||
-- types do not express that they actually are transformers. This replacement
|
||||
-- class accounts for this.
|
||||
class MonadLift base m | m -> base where
|
||||
lift :: base a -> m a
|
||||
instance (Monad m, MonadTrans t) => MonadLift m (t m) where
|
||||
lift = Control.Monad.Trans.Class.lift
|
||||
instance MonadLift (ResourceT IO) (GHandler sub master) where
|
||||
lift = GHandler . const
|
||||
|
||||
-- Instances for GHandler
|
||||
instance Functor (GHandler sub master) where
|
||||
fmap f (GHandler x) = GHandler $ \r -> fmap f (x r)
|
||||
instance Applicative (GHandler sub master) where
|
||||
pure = GHandler . const . pure
|
||||
GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r
|
||||
instance Monad (GHandler sub master) where
|
||||
return = pure
|
||||
GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r
|
||||
instance MonadIO (GHandler sub master) where
|
||||
liftIO = GHandler . const . lift
|
||||
instance MonadBase IO (GHandler sub master) where
|
||||
liftBase = GHandler . const . lift
|
||||
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
|
||||
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
|
||||
-- Instead, if you must fork a separate thread, you should use
|
||||
-- @resourceForkIO@.
|
||||
--
|
||||
-- Using fork usually leads to an exception that says
|
||||
-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
|
||||
-- after cleanup. Please contact the maintainers.\"
|
||||
instance MonadBaseControl IO (GHandler sub master) where
|
||||
data StM (GHandler sub master) a = StH (StM (ResourceT IO) a)
|
||||
liftBaseWith f = GHandler $ \reader ->
|
||||
liftBaseWith $ \runInBase ->
|
||||
f $ liftM StH . runInBase . (\(GHandler r) -> r reader)
|
||||
restoreM (StH base) = GHandler $ const $ restoreM base
|
||||
|
||||
instance MonadUnsafeIO (GHandler sub master) where
|
||||
unsafeLiftIO = liftIO
|
||||
instance MonadThrow (GHandler sub master) where
|
||||
monadThrow = liftIO . throwIO
|
||||
instance MonadResource (GHandler sub master) where
|
||||
#if MIN_VERSION_resourcet(0,4,0)
|
||||
liftResourceT = lift . liftResourceT
|
||||
#else
|
||||
allocate a = lift . allocate a
|
||||
register = lift . register
|
||||
release = lift . release
|
||||
resourceMask = lift . resourceMask
|
||||
#endif
|
||||
|
||||
instance MonadLogger (GHandler sub master) where
|
||||
#if MIN_VERSION_monad_logger(0, 3, 0)
|
||||
monadLoggerLog a b c d = do
|
||||
hd <- ask
|
||||
liftIO $ handlerLog hd a b c (toLogStr d)
|
||||
#else
|
||||
monadLoggerLog a c d = monadLoggerLogSource a "" c d
|
||||
monadLoggerLogSource a b c d = do
|
||||
hd <- ask
|
||||
liftIO $ handlerLog hd a b c (toLogStr d)
|
||||
#endif
|
||||
|
||||
instance Exception e => Failure e (GHandler sub master) where
|
||||
failure = liftIO . throwIO
|
||||
|
||||
@ -30,108 +30,24 @@ module Yesod.Internal
|
||||
, tokenKey
|
||||
) where
|
||||
|
||||
import Text.Hamlet (HtmlUrl, Html)
|
||||
import Text.Hamlet (HtmlUrl)
|
||||
import Text.Blaze.Html (toHtml)
|
||||
import Text.Julius (JavascriptUrl)
|
||||
import Data.Monoid (Monoid (..), Last)
|
||||
import Data.List (nub)
|
||||
|
||||
import Data.Text (Text)
|
||||
|
||||
import Data.Typeable (Typeable)
|
||||
import Control.Exception (Exception)
|
||||
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Data.String (IsString)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text.Lazy.Builder (Builder)
|
||||
import Web.Cookie (SetCookie (..))
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Network.Wai as W
|
||||
import Yesod.Content (ChooseRep, ContentType)
|
||||
|
||||
-- | Responses to indicate some form of an error occurred. These are different
|
||||
-- from 'SpecialResponse' in that they allow for custom error pages.
|
||||
data ErrorResponse =
|
||||
NotFound
|
||||
| InternalError Text
|
||||
| InvalidArgs [Text]
|
||||
| PermissionDenied Text
|
||||
| BadMethod H.Method
|
||||
deriving (Show, Eq, Typeable)
|
||||
|
||||
----- header stuff
|
||||
-- | Headers to be added to a 'Result'.
|
||||
data Header =
|
||||
AddCookie SetCookie
|
||||
| DeleteCookie ByteString ByteString
|
||||
| Header ByteString ByteString
|
||||
deriving (Eq, Show)
|
||||
import Yesod.Core.Types
|
||||
|
||||
langKey :: IsString a => a
|
||||
langKey = "_LANG"
|
||||
|
||||
data Location url = Local url | Remote Text
|
||||
deriving (Show, Eq)
|
||||
locationToHtmlUrl :: Location url -> HtmlUrl url
|
||||
locationToHtmlUrl (Local url) render = toHtml $ render url []
|
||||
locationToHtmlUrl (Remote s) _ = toHtml s
|
||||
|
||||
newtype UniqueList x = UniqueList ([x] -> [x])
|
||||
instance Monoid (UniqueList x) where
|
||||
mempty = UniqueList id
|
||||
UniqueList x `mappend` UniqueList y = UniqueList $ x . y
|
||||
runUniqueList :: Eq x => UniqueList x -> [x]
|
||||
runUniqueList (UniqueList x) = nub $ x []
|
||||
toUnique :: x -> UniqueList x
|
||||
toUnique = UniqueList . (:)
|
||||
|
||||
data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
newtype Title = Title { unTitle :: Html }
|
||||
|
||||
newtype Head url = Head (HtmlUrl url)
|
||||
deriving Monoid
|
||||
newtype Body url = Body (HtmlUrl url)
|
||||
deriving Monoid
|
||||
|
||||
tokenKey :: IsString a => a
|
||||
tokenKey = "_TOKEN"
|
||||
|
||||
type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder
|
||||
|
||||
data GWData a = GWData
|
||||
{ gwdBody :: !(Body a)
|
||||
, gwdTitle :: !(Last Title)
|
||||
, gwdScripts :: !(UniqueList (Script a))
|
||||
, gwdStylesheets :: !(UniqueList (Stylesheet a))
|
||||
, gwdCss :: !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
|
||||
, gwdJavascript :: !(Maybe (JavascriptUrl a))
|
||||
, gwdHead :: !(Head a)
|
||||
}
|
||||
instance Monoid (GWData a) where
|
||||
mempty = GWData mempty mempty mempty mempty mempty mempty mempty
|
||||
mappend (GWData a1 a2 a3 a4 a5 a6 a7)
|
||||
(GWData b1 b2 b3 b4 b5 b6 b7) = GWData
|
||||
(a1 `mappend` b1)
|
||||
(a2 `mappend` b2)
|
||||
(a3 `mappend` b3)
|
||||
(a4 `mappend` b4)
|
||||
(Map.unionWith mappend a5 b5)
|
||||
(a6 `mappend` b6)
|
||||
(a7 `mappend` b7)
|
||||
|
||||
data HandlerContents =
|
||||
HCContent H.Status ChooseRep
|
||||
| HCError ErrorResponse
|
||||
| HCSendFile ContentType FilePath (Maybe W.FilePart)
|
||||
| HCRedirect H.Status Text
|
||||
| HCCreated Text
|
||||
| HCWai W.Response
|
||||
deriving Typeable
|
||||
|
||||
instance Show HandlerContents where
|
||||
show _ = "Cannot show a HandlerContents"
|
||||
instance Exception HandlerContents
|
||||
|
||||
@ -14,15 +14,9 @@ import qualified Data.IntMap as Map
|
||||
import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL))
|
||||
import Language.Haskell.TH (appE)
|
||||
import Data.Unique (hashUnique, newUnique)
|
||||
import GHC.Exts (Any)
|
||||
import Unsafe.Coerce (unsafeCoerce)
|
||||
import Data.Monoid (Monoid)
|
||||
import Control.Applicative ((<$>))
|
||||
|
||||
newtype Cache = Cache (Map.IntMap Any)
|
||||
deriving Monoid
|
||||
|
||||
newtype CacheKey a = CacheKey Int
|
||||
import Yesod.Core.Types
|
||||
|
||||
-- | Generate a new 'CacheKey'. Be sure to give a full type signature.
|
||||
mkCacheKey :: Q Exp
|
||||
|
||||
@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
-- | The basic typeclass for a Yesod application.
|
||||
module Yesod.Internal.Core
|
||||
( -- * Type classes
|
||||
@ -95,6 +96,7 @@ import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerP
|
||||
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource)
|
||||
import System.Log.FastLogger.Date (ZonedDate)
|
||||
import System.IO (stdout)
|
||||
import Yesod.Core.Types
|
||||
|
||||
yesodVersion :: String
|
||||
yesodVersion = showVersion Paths_yesod_core.version
|
||||
@ -126,18 +128,6 @@ class YesodDispatch sub master where
|
||||
-> W.Application
|
||||
yesodRunner = defaultYesodRunner
|
||||
|
||||
-- | How to determine the root of the application for constructing URLs.
|
||||
--
|
||||
-- Note that future versions of Yesod may add new constructors without bumping
|
||||
-- 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)
|
||||
|
||||
type ResolvedApproot = Text
|
||||
|
||||
-- | Define settings for a Yesod applications. All methods have intelligent
|
||||
-- defaults, and therefore no implementation is required.
|
||||
class RenderRoute a => Yesod a where
|
||||
@ -472,9 +462,6 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
|
||||
maxLen = maximumContentLength master $ fmap toMasterRoute murl
|
||||
handler = yesodMiddleware handler'
|
||||
|
||||
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
|
||||
deriving (Eq, Show, Read)
|
||||
|
||||
-- | A type-safe, concise method of creating breadcrumbs for pages. For each
|
||||
-- resource, you declare the title of the page and the parent resource (if
|
||||
-- present).
|
||||
@ -664,16 +651,6 @@ $newline never
|
||||
: attrs
|
||||
)
|
||||
|
||||
data ScriptLoadPosition master
|
||||
= BottomOfBody
|
||||
| BottomOfHeadBlocking
|
||||
| BottomOfHeadAsync (BottomOfHeadAsync master)
|
||||
|
||||
type BottomOfHeadAsync master
|
||||
= [Text] -- ^ urls to load asynchronously
|
||||
-> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion
|
||||
-> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>
|
||||
|
||||
left :: Either a b -> Maybe a
|
||||
left (Left x) = Just x
|
||||
left _ = Nothing
|
||||
@ -874,3 +851,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
|
||||
_ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap
|
||||
I.readIORef ret
|
||||
{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
|
||||
|
||||
instance YesodDispatch WaiSubsite master where
|
||||
yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
|
||||
|
||||
@ -43,17 +43,7 @@ import Data.Conduit.Binary (sourceFile, sinkFile)
|
||||
import Data.Word (Word64)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Exception (throwIO)
|
||||
|
||||
-- | The parsed request information.
|
||||
data Request = Request
|
||||
{ reqGetParams :: [(Text, Text)]
|
||||
, reqCookies :: [(Text, Text)]
|
||||
, reqWaiRequest :: W.Request
|
||||
-- | Languages which the client supports.
|
||||
, reqLangs :: [Text]
|
||||
-- | A random, session-specific token used to prevent CSRF attacks.
|
||||
, reqToken :: Maybe Text
|
||||
}
|
||||
import Yesod.Core.Types
|
||||
|
||||
parseWaiRequest :: W.Request
|
||||
-> [(Text, ByteString)] -- ^ session
|
||||
@ -149,19 +139,6 @@ randomString len = take len . map toChar . randomRs (0, 61)
|
||||
| i < 52 = toEnum $ i + fromEnum 'a' - 26
|
||||
| otherwise = toEnum $ i + fromEnum '0' - 52
|
||||
|
||||
-- | A tuple containing both the POST parameters and submitted files.
|
||||
type RequestBodyContents =
|
||||
( [(Text, Text)]
|
||||
, [(Text, FileInfo)]
|
||||
)
|
||||
|
||||
data FileInfo = FileInfo
|
||||
{ fileName :: Text
|
||||
, fileContentType :: Text
|
||||
, fileSource :: Source (ResourceT IO) ByteString
|
||||
, fileMove :: FilePath -> IO ()
|
||||
}
|
||||
|
||||
mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
|
||||
mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs)
|
||||
|
||||
@ -170,7 +147,3 @@ mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourc
|
||||
|
||||
mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo
|
||||
mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)
|
||||
|
||||
data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString)
|
||||
| FileUploadDisk (NWP.BackEnd FilePath)
|
||||
| FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString))
|
||||
|
||||
@ -8,32 +8,16 @@ module Yesod.Internal.Session
|
||||
, SessionBackend(..)
|
||||
) where
|
||||
|
||||
import Yesod.Internal (Header(..))
|
||||
import qualified Web.ClientSession as CS
|
||||
import Data.Int (Int64)
|
||||
import Data.Serialize
|
||||
import Data.Time
|
||||
import Data.ByteString (ByteString)
|
||||
import Control.Concurrent (forkIO, killThread, threadDelay)
|
||||
import Control.Monad (forever, guard)
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import Control.Arrow (first)
|
||||
import Control.Applicative ((<$>))
|
||||
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Data.Text (Text)
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Time
|
||||
import qualified Data.IORef as I
|
||||
import qualified Network.Wai as W
|
||||
|
||||
type BackendSession = [(Text, S8.ByteString)]
|
||||
|
||||
type SaveSession = BackendSession -- ^ The session contents after running the handler
|
||||
-> IO [Header]
|
||||
|
||||
newtype SessionBackend master = SessionBackend
|
||||
{ sbLoadSession :: master
|
||||
-> W.Request
|
||||
-> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session
|
||||
}
|
||||
|
||||
encodeClientSession :: CS.Key
|
||||
-> CS.IV
|
||||
@ -58,19 +42,6 @@ decodeClientSession key date rhost encrypted = do
|
||||
guard $ rhost' == rhost
|
||||
return session'
|
||||
|
||||
data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)]
|
||||
deriving (Show, Read)
|
||||
instance Serialize SessionCookie where
|
||||
put (SessionCookie a b c) = do
|
||||
either putTime putByteString a
|
||||
put b
|
||||
put (map (first unpack) c)
|
||||
get = do
|
||||
a <- getTime
|
||||
b <- get
|
||||
c <- map (first pack) <$> get
|
||||
return $ SessionCookie (Left a) b c
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
@ -81,13 +52,6 @@ instance Serialize SessionCookie where
|
||||
-- The cached date is updated every 10s, we don't need second
|
||||
-- resolution for session expiration times.
|
||||
|
||||
data ClientSessionDateCache =
|
||||
ClientSessionDateCache {
|
||||
csdcNow :: !UTCTime
|
||||
, csdcExpires :: !UTCTime
|
||||
, csdcExpiresSerialized :: !ByteString
|
||||
} deriving (Eq, Show)
|
||||
|
||||
clientSessionDateCacher ::
|
||||
NominalDiffTime -- ^ Inactive session valitity.
|
||||
-> IO (IO ClientSessionDateCache, IO ())
|
||||
@ -104,27 +68,3 @@ clientSessionDateCacher validity = do
|
||||
doUpdate ref = do
|
||||
threadDelay 10000000 -- 10s
|
||||
I.writeIORef ref =<< getUpdated
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
|
||||
putTime :: Putter UTCTime
|
||||
putTime (UTCTime d t) =
|
||||
let d' = fromInteger $ toModifiedJulianDay d
|
||||
t' = fromIntegral $ fromEnum (t / diffTimeScale)
|
||||
in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')
|
||||
|
||||
getTime :: Get UTCTime
|
||||
getTime = do
|
||||
val <- get
|
||||
let (d, t) = val `divMod` posixDayLength_int64
|
||||
d' = ModifiedJulianDay $! fromIntegral d
|
||||
t' = fromIntegral t
|
||||
d' `seq` t' `seq` return (UTCTime d' t')
|
||||
|
||||
posixDayLength_int64 :: Int64
|
||||
posixDayLength_int64 = 86400
|
||||
|
||||
diffTimeScale :: DiffTime
|
||||
diffTimeScale = 1e12
|
||||
|
||||
@ -1,6 +0,0 @@
|
||||
-- | This module has moved to "Text.Shakespeare.I18N"
|
||||
module Yesod.Message
|
||||
( module Text.Shakespeare.I18N
|
||||
) where
|
||||
|
||||
import Text.Shakespeare.I18N
|
||||
@ -52,13 +52,11 @@ import Text.Cassius
|
||||
import Text.Julius
|
||||
import Yesod.Routes.Class
|
||||
import Yesod.Handler
|
||||
( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
( YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
, getMessageRender, getUrlRenderParams, MonadLift (..)
|
||||
)
|
||||
import Yesod.Message (RenderMessage)
|
||||
import Yesod.Content (RepHtml (..), toContent)
|
||||
import Control.Applicative (Applicative (..), (<$>))
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Text.Shakespeare.I18N (RenderMessage)
|
||||
import Yesod.Content (toContent)
|
||||
import Yesod.Internal
|
||||
import Control.Monad (liftM)
|
||||
import Data.Text (Text)
|
||||
@ -66,32 +64,16 @@ import qualified Data.Map as Map
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
|
||||
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Exception (throwIO)
|
||||
import qualified Text.Hamlet as NP
|
||||
import Data.Text.Lazy.Builder (fromLazyText, Builder)
|
||||
import Data.Text.Lazy.Builder (fromLazyText)
|
||||
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Control.Monad.Base (MonadBase (liftBase))
|
||||
import Control.Arrow (first)
|
||||
import Control.Monad.Trans.Resource
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Yesod.Core.Types
|
||||
|
||||
preEscapedLazyText :: TL.Text -> Html
|
||||
preEscapedLazyText = preEscapedToMarkup
|
||||
|
||||
-- | A generic widget, allowing specification of both the subsite and master
|
||||
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
|
||||
-- better error messages.
|
||||
newtype GWidget sub master a = GWidget
|
||||
{ unGWidget :: GHandler sub master (a, GWData (Route master))
|
||||
}
|
||||
|
||||
instance (a ~ ()) => Monoid (GWidget sub master a) where
|
||||
mempty = return ()
|
||||
mappend x y = x >> y
|
||||
|
||||
addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
|
||||
addSubWidget sub (GWidget w) = do
|
||||
master <- lift getYesod
|
||||
@ -103,17 +85,6 @@ addSubWidget sub (GWidget w) = do
|
||||
class ToWidget sub master a where
|
||||
toWidget :: a -> GWidget sub master ()
|
||||
|
||||
type RY master = Route master -> [(Text, Text)] -> Text
|
||||
|
||||
-- | Newtype wrapper allowing injection of arbitrary content into CSS.
|
||||
--
|
||||
-- Usage:
|
||||
--
|
||||
-- > toWidget $ CssBuilder "p { color: red }"
|
||||
--
|
||||
-- Since: 1.1.3
|
||||
newtype CssBuilder = CssBuilder { unCssBuilder :: Builder }
|
||||
|
||||
instance render ~ RY master => ToWidget sub master (render -> Html) where
|
||||
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
|
||||
instance render ~ RY master => ToWidget sub master (render -> Css) where
|
||||
@ -216,16 +187,6 @@ addScriptRemote = flip addScriptRemoteAttrs []
|
||||
addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
|
||||
addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
|
||||
-- | Content for a web page. By providing this datatype, we can easily create
|
||||
-- generic site templates, which would have the type signature:
|
||||
--
|
||||
-- > PageContent url -> HtmlUrl url
|
||||
data PageContent url = PageContent
|
||||
{ pageTitle :: Html
|
||||
, pageHead :: HtmlUrl url
|
||||
, pageBody :: HtmlUrl url
|
||||
}
|
||||
|
||||
whamlet :: QuasiQuoter
|
||||
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
|
||||
|
||||
@ -264,58 +225,6 @@ ihamletToRepHtml ih = do
|
||||
tell :: GWData (Route master) -> GWidget sub master ()
|
||||
tell w = GWidget $ return ((), w)
|
||||
|
||||
instance MonadLift (GHandler sub master) (GWidget sub master) where
|
||||
lift = GWidget . fmap (\x -> (x, mempty))
|
||||
|
||||
-- | Type-restricted version of @lift@
|
||||
liftW :: GHandler sub master a -> GWidget sub master a
|
||||
liftW = lift
|
||||
|
||||
-- Instances for GWidget
|
||||
instance Functor (GWidget sub master) where
|
||||
fmap f (GWidget x) = GWidget (fmap (first f) x)
|
||||
instance Applicative (GWidget sub master) where
|
||||
pure a = GWidget $ pure (a, mempty)
|
||||
GWidget f <*> GWidget v =
|
||||
GWidget $ k <$> f <*> v
|
||||
where
|
||||
k (a, wa) (b, wb) = (a b, wa `mappend` wb)
|
||||
instance Monad (GWidget sub master) where
|
||||
return = pure
|
||||
GWidget x >>= f = GWidget $ do
|
||||
(a, wa) <- x
|
||||
(b, wb) <- unGWidget (f a)
|
||||
return (b, wa `mappend` wb)
|
||||
instance MonadIO (GWidget sub master) where
|
||||
liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO
|
||||
instance MonadBase IO (GWidget sub master) where
|
||||
liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase
|
||||
instance MonadBaseControl IO (GWidget sub master) where
|
||||
data StM (GWidget sub master) a =
|
||||
StW (StM (GHandler sub master) (a, GWData (Route master)))
|
||||
liftBaseWith f = GWidget $ liftBaseWith $ \runInBase ->
|
||||
liftM (\x -> (x, mempty))
|
||||
(f $ liftM StW . runInBase . unGWidget)
|
||||
restoreM (StW base) = GWidget $ restoreM base
|
||||
|
||||
instance MonadUnsafeIO (GWidget sub master) where
|
||||
unsafeLiftIO = liftIO
|
||||
instance MonadThrow (GWidget sub master) where
|
||||
monadThrow = liftIO . throwIO
|
||||
instance MonadResource (GWidget sub master) where
|
||||
#if MIN_VERSION_resourcet(0,4,0)
|
||||
liftResourceT = lift . liftResourceT
|
||||
#else
|
||||
allocate a = lift . allocate a
|
||||
register = lift . register
|
||||
release = lift . release
|
||||
resourceMask = lift . resourceMask
|
||||
#endif
|
||||
|
||||
instance MonadLogger (GWidget sub master) where
|
||||
#if MIN_VERSION_monad_logger(0, 3, 0)
|
||||
monadLoggerLog a b c = lift . monadLoggerLog a b c
|
||||
#else
|
||||
monadLoggerLog a b = lift . monadLoggerLog a b
|
||||
monadLoggerLogSource a b c = lift . monadLoggerLogSource a b c
|
||||
#endif
|
||||
|
||||
@ -80,9 +80,9 @@ library
|
||||
, vector >= 0.9 && < 0.11
|
||||
, aeson >= 0.5
|
||||
, fast-logger >= 0.2
|
||||
, monad-logger >= 0.2.1 && < 0.4
|
||||
, monad-logger >= 0.3 && < 0.4
|
||||
, conduit >= 0.5
|
||||
, resourcet >= 0.3 && < 0.5
|
||||
, resourcet >= 0.4 && < 0.5
|
||||
, lifted-base >= 0.1
|
||||
, attoparsec-conduit
|
||||
, blaze-html >= 0.5
|
||||
@ -95,13 +95,15 @@ library
|
||||
Yesod.Handler
|
||||
Yesod.Request
|
||||
Yesod.Widget
|
||||
Yesod.Message
|
||||
Yesod.Internal.TestApi
|
||||
other-modules: Yesod.Internal
|
||||
Yesod.Internal.Cache
|
||||
Yesod.Internal.Core
|
||||
Yesod.Internal.Session
|
||||
Yesod.Internal.Request
|
||||
Yesod.Core.Types
|
||||
Yesod.Core.Time
|
||||
Yesod.Core.Trans.Class
|
||||
Paths_yesod_core
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user