Sorted Contrib stuff into regular hierarchy
This commit is contained in:
parent
59c56c1256
commit
93ad24f969
4
Yesod.hs
4
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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user