diff --git a/Yesod.hs b/Yesod.hs index 56f5b623..90fa85bd 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -10,7 +10,7 @@ module Yesod , module Yesod.Form , module Yesod.Hamlet , module Yesod.Json - , module Yesod.Contrib + , module Yesod.Formable , Application , liftIO , Routes @@ -28,10 +28,10 @@ import Yesod.Dispatch import Yesod.Request import Yesod.Form hiding (Form) +import Yesod.Formable import Yesod.Yesod import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet import "transformers" Control.Monad.IO.Class (liftIO) import Web.Routes.Quasi (Routes) -import Yesod.Contrib diff --git a/Yesod/Contrib.hs b/Yesod/Contrib.hs deleted file mode 100644 index a14027c0..00000000 --- a/Yesod/Contrib.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Yesod.Contrib - ( module Yesod.Contrib.Formable - , module Yesod.Contrib.Crud - , module Yesod.Contrib.Persist - ) where - -import Yesod.Contrib.Formable hiding (runForm) -import Yesod.Contrib.Crud -import Yesod.Contrib.Persist diff --git a/Yesod/Contrib/Persist.hs b/Yesod/Contrib/Persist.hs deleted file mode 100644 index fdb36318..00000000 --- a/Yesod/Contrib/Persist.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Yesod.Contrib.Persist - ( YesodPersist (..) - , Persist (..) - ) where - -import Yesod.Handler -import Database.Persist - -class YesodPersist y where - type YesodDB y :: (* -> *) -> * -> * - runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 719198f1..0b26ba5c 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -55,8 +55,10 @@ import Data.Time import Control.Monad import Data.Maybe import Web.ClientSession +import qualified Web.ClientSession as CS import Data.Serialize +import qualified Data.Serialize as Ser import Network.Wai.Parse #if TEST @@ -336,7 +338,7 @@ headerToPair _ (DeleteCookie key) = headerToPair _ (Header key value) = (W.responseHeaderFromBS $ S.fromString key, S.fromString value) -encodeSession :: Key +encodeSession :: CS.Key -> UTCTime -- ^ expire time -> B.ByteString -- ^ remote host -> [(String, String)] -- ^ session @@ -344,7 +346,7 @@ encodeSession :: Key encodeSession key expire rhost session' = encrypt key $ encode $ SessionCookie expire rhost session' -decodeSession :: Key +decodeSession :: CS.Key -> UTCTime -- ^ current time -> B.ByteString -- ^ remote host field -> B.ByteString -- ^ cookie value @@ -363,8 +365,8 @@ instance Serialize SessionCookie where put (SessionCookie a b c) = putTime a >> put b >> put c get = do a <- getTime - b <- get - c <- get + b <- Ser.get + c <- Ser.get return $ SessionCookie a b c putTime :: Putter UTCTime @@ -375,8 +377,8 @@ putTime t@(UTCTime d _) = do getTime :: Get UTCTime getTime = do - d <- get - ndt <- get + d <- Ser.get + ndt <- Ser.get return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 #if TEST diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Formable.hs similarity index 91% rename from Yesod/Contrib/Formable.hs rename to Yesod/Formable.hs index 5af2ca48..3a31a9cd 100644 --- a/Yesod/Contrib/Formable.hs +++ b/Yesod/Formable.hs @@ -3,12 +3,24 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -module Yesod.Contrib.Formable where +module Yesod.Formable + ( Form (..) + , Formlet + , SealedForm (..) + , SealedFormlet + , runForm + , runIncr + , Formable (..) + , Fieldable (..) + , deriveFormable + , share2 + , wrapperRow + , sealFormlet + ) where import Text.Hamlet import Data.Time (Day) import Control.Applicative -import Web.Routes.Quasi (SinglePiece) import Database.Persist (Persistable) import Data.Char (isAlphaNum) import Language.Haskell.TH.Syntax @@ -19,6 +31,17 @@ import Control.Arrow (first) import Data.Maybe (fromMaybe) import Data.Monoid (mempty, mappend) import qualified Data.ByteString.Lazy.UTF8 +import Yesod.Request +import Yesod.Handler +import Control.Monad.IO.Class (liftIO) +import Web.Routes.Quasi + +runForm :: SealedForm (Routes y) a + -> GHandler sub y (Either [String] a, Hamlet (Routes y)) +runForm f = do + req <- getRequest + (pp, _) <- liftIO $ reqRequestBody req + return $ fst $ runIncr (runSealedForm f pp) 1 type Env = [(String, String)] @@ -39,9 +62,7 @@ instance Functor FormResult where fmap _ (FormFailure errs) = FormFailure errs fmap f (FormSuccess a) = FormSuccess $ f a -newtype Form url a = Form - { runForm :: Env -> Incr (FormResult a, Hamlet url) - } +newtype Form url a = Form (Env -> Incr (FormResult a, Hamlet url)) type Formlet url a = Maybe a -> Form url a newtype SealedForm url a = SealedForm diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Helpers/Crud.hs similarity index 92% rename from Yesod/Contrib/Crud.hs rename to Yesod/Helpers/Crud.hs index 6da09ded..24ba65ca 100644 --- a/Yesod/Contrib/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -1,28 +1,21 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} -module Yesod.Contrib.Crud where +module Yesod.Helpers.Crud + ( Item (..) + , Crud (..) + , defaultCrud + , siteCrud + ) where import Yesod.Yesod import Yesod.Dispatch import Yesod.Content import Yesod.Handler -import Yesod.Request import Text.Hamlet -import Control.Monad.IO.Class (liftIO) -import Web.Routes.Quasi -import Database.Persist -import Yesod.Contrib.Formable hiding (runForm) -import Yesod.Contrib.Persist +import Yesod.Formable import Data.Monoid (mempty) -runForm :: SealedForm (Routes y) a - -> GHandler sub y (Either [String] a, Hamlet (Routes y)) -runForm f = do - req <- getRequest - (pp, _) <- liftIO $ reqRequestBody req - return $ fst $ runIncr (runSealedForm f pp) 1 - class Formable a => Item a where itemTitle :: a -> String diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index b75eee0d..3cf87abe 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,10 +1,14 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( -- * Type classes Yesod (..) , YesodSite (..) + -- ** Persistence + , YesodPersist (..) + , Persist (..) -- * Convenience functions , applyLayout , applyLayoutJson @@ -19,9 +23,11 @@ import Yesod.Handler import qualified Network.Wai as W import Yesod.Json import Yesod.Internal -import Web.ClientSession (getKey, defaultKeyFile, Key) +import Web.ClientSession (getKey, defaultKeyFile) +import qualified Web.ClientSession as CS import Data.Monoid (mempty) import Data.ByteString.UTF8 (toString) +import Database.Persist (Persist (..)) import Web.Routes.Quasi (QuasiSite (..), Routes) @@ -46,7 +52,7 @@ class Yesod a where approot :: a -> String -- | The encryption key to be used for encrypting client sessions. - encryptKey :: a -> IO Key + encryptKey :: a -> IO CS.Key encryptKey _ = getKey defaultKeyFile -- | Number of minutes before a client session times out. Defaults to @@ -162,3 +168,7 @@ defaultErrorHandler (BadMethod m) = %h1 Method Not Supported %p Method "$string.m$" not supported |] + +class YesodPersist y where + type YesodDB y :: (* -> *) -> * -> * + runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a diff --git a/yesod.cabal b/yesod.cabal index 182222f5..f321c799 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -58,6 +58,7 @@ library Yesod.Content Yesod.Dispatch Yesod.Form + Yesod.Formable Yesod.Hamlet Yesod.Handler Yesod.Internal @@ -66,13 +67,10 @@ library Yesod.Yesod Yesod.Helpers.AtomFeed Yesod.Helpers.Auth + Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static - Yesod.Contrib - Yesod.Contrib.Crud - Yesod.Contrib.Formable - Yesod.Contrib.Persist - ghc-options: -Wall + ghc-options: -Wall -Werror executable runtests if flag(buildtests)