haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removed all FIXMEs but Test.Errors and Yesod.Template

Browse Source
This commit is contained in:
Michael Snoyman 2010-01-26 21:06:41 +02:00
parent ecb4d2f334
commit bfc9b224c0
11 changed files with 116 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
Data/Object/Html.hs
View File

@ -4,7 +4,6 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
-- | An 'Html' data type and associated 'ConvertSuccess' instances. This has -- | An 'Html' data type and associated 'ConvertSuccess' instances. This has
-- useful conversions in web development: -- useful conversions in web development:
-- --
@ -66,6 +65,17 @@ newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text }
type HtmlObject = Object String Html type HtmlObject = Object String Html
instance ConvertSuccess Html HtmlObject where
convertSuccess = Scalar
instance ConvertSuccess [Html] HtmlObject where
convertSuccess = Sequence . map cs
instance ConvertSuccess [HtmlObject] HtmlObject where
convertSuccess = Sequence
instance ConvertSuccess [(String, HtmlObject)] HtmlObject where
convertSuccess = Mapping
instance ConvertSuccess [(String, Html)] HtmlObject where
convertSuccess = Mapping . map (second cs)
toHtmlObject :: ConvertSuccess x HtmlObject => x -> HtmlObject toHtmlObject :: ConvertSuccess x HtmlObject => x -> HtmlObject
toHtmlObject = cs toHtmlObject = cs
@ -78,11 +88,6 @@ instance ConvertSuccess TS.Text Html where
convertSuccess = Text convertSuccess = Text
instance ConvertSuccess Text Html where instance ConvertSuccess Text Html where
convertSuccess = Text . cs convertSuccess = Text . cs
$(deriveAttempts
[ (''String, ''Html)
, (''Text, ''Html)
, (''TS.Text, ''Html)
])
instance ConvertSuccess String HtmlObject where instance ConvertSuccess String HtmlObject where
convertSuccess = Scalar . cs convertSuccess = Scalar . cs
@ -151,11 +156,19 @@ cdata h = HtmlList
, Html $ cs "]]>" , Html $ cs "]]>"
] ]
instance ConvertSuccess Html HtmlDoc where instance ConvertSuccess (Html, Html) HtmlDoc where
convertSuccess h = HtmlDoc $ TL.fromChunks $ convertSuccess (h, b) = HtmlDoc $ TL.fromChunks $
cs "<!DOCTYPE html>\n<html><head><title>HtmlDoc (autogenerated)</title></head><body>" cs "<!DOCTYPE html>\n"
: htmlToText False h : htmlToText False (Tag "html" [] $ HtmlList
[cs "</body></html>"] [ Tag "head" [] h
, Tag "body" [] b
]
) []
instance ConvertSuccess (HtmlObject, HtmlObject) HtmlDoc where
convertSuccess (x, y) = cs (cs' x :: Html, cs' y) where
cs' = cs
instance ConvertSuccess (HtmlObject, HtmlObject) JsonDoc where
convertSuccess (_, y) = cs y
instance ConvertSuccess HtmlObject Html where instance ConvertSuccess HtmlObject Html where
convertSuccess (Scalar h) = h convertSuccess (Scalar h) = h
@ -169,25 +182,20 @@ instance ConvertSuccess HtmlObject Html where
, Tag "dd" [] $ cs v , Tag "dd" [] $ cs v
] ]
instance ConvertSuccess HtmlObject HtmlDoc where
convertSuccess = cs . (cs :: HtmlObject -> Html)
instance ConvertSuccess Html JsonScalar where instance ConvertSuccess Html JsonScalar where
convertSuccess = cs . unHtmlFragment . cs convertSuccess = cs . unHtmlFragment . cs
instance ConvertAttempt Html JsonScalar where
convertAttempt = return . cs
instance ConvertSuccess HtmlObject JsonObject where instance ConvertSuccess HtmlObject JsonObject where
convertSuccess = mapKeysValues convertSuccess convertSuccess convertSuccess = mapKeysValues convertSuccess convertSuccess
instance ConvertAttempt HtmlObject JsonObject where
convertAttempt = return . cs
instance ConvertSuccess HtmlObject JsonDoc where instance ConvertSuccess HtmlObject JsonDoc where
convertSuccess = cs . (cs :: HtmlObject -> JsonObject) convertSuccess = cs . (cs :: HtmlObject -> JsonObject)
instance ConvertAttempt HtmlObject JsonDoc where
$(deriveAttempts convertAttempt = return . cs
[ (''Html, ''HtmlFragment)
, (''Html, ''HtmlDoc)
, (''Html, ''JsonScalar)
])
$(deriveSuccessConvs ''String ''Html
[''String, ''Text]
[''Html, ''HtmlFragment])
instance ToSElem HtmlObject where instance ToSElem HtmlObject where
toSElem (Scalar h) = STR $ TL.unpack $ unHtmlFragment $ cs h toSElem (Scalar h) = STR $ TL.unpack $ unHtmlFragment $ cs h

5
TODO
View File

@ -1,6 +1 @@
Some form of i18n.
Cleanup Parameter stuff. Own module? Interface with formlets? Cleanup Parameter stuff. Own module? Interface with formlets?
Authentication via e-mail address built in. (eaut.org)
OpenID 2 stuff (for direct Google login).
Languages (read languages header, set language cookie)
Approot and trailing slash missing

9
Test/Errors.hs
View File

@ -9,7 +9,6 @@ import Data.List
import Test.Framework (testGroup, Test) import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test) import Test.HUnit hiding (Test)
import Control.Applicative
data Errors = Errors data Errors = Errors
instance Yesod Errors where instance Yesod Errors where
@ -28,19 +27,19 @@ instance YesodAuth Errors
denied :: Handler Errors () denied :: Handler Errors ()
denied = permissionDenied denied = permissionDenied
needsIdent :: Handler Errors HtmlObject needsIdent :: Handler Errors (HtmlObject, HtmlObject)
needsIdent = do needsIdent = do
i <- authIdentifier i <- authIdentifier
return $ toHtmlObject i return $ (toHtmlObject "", toHtmlObject i)
hasArgs :: Handler Errors HtmlObject hasArgs :: Handler Errors (HtmlObject, HtmlObject)
hasArgs = do hasArgs = do
{- FIXME wait for new request API {- FIXME wait for new request API
(a, b) <- runRequest $ (,) <$> getParam "firstParam" (a, b) <- runRequest $ (,) <$> getParam "firstParam"
<*> getParam "secondParam" <*> getParam "secondParam"
-} -}
let (a, b) = ("foo", "bar") let (a, b) = ("foo", "bar")
return $ toHtmlObject [a :: String, b] return (toHtmlObject "", toHtmlObject [a :: String, b])
caseErrorMessages :: Assertion caseErrorMessages :: Assertion
caseErrorMessages = do caseErrorMessages = do

38
Test/QuasiResource.hs
View File

@ -14,24 +14,30 @@ data MyYesod = MyYesod
instance Show (Handler MyYesod ChooseRep) where show _ = "Another handler" instance Show (Handler MyYesod ChooseRep) where show _ = "Another handler"
getStatic :: Verb -> [String] -> Handler MyYesod HtmlObject addHead' :: HtmlObject -> (HtmlObject, HtmlObject)
getStatic v p = return $ toHtmlObject ["getStatic", show v, show p] addHead' x = (cs "", x)
pageIndex :: Handler MyYesod HtmlObject
pageIndex = return $ toHtmlObject ["pageIndex"] addHead :: Monad m => HtmlObject -> m (HtmlObject, HtmlObject)
addHead = return . addHead'
getStatic :: Verb -> [String] -> Handler MyYesod (HtmlObject, HtmlObject)
getStatic v p = addHead $ toHtmlObject ["getStatic", show v, show p]
pageIndex :: Handler MyYesod (HtmlObject, HtmlObject)
pageIndex = addHead $ toHtmlObject ["pageIndex"]
pageAdd :: Handler MyYesod ChooseRep pageAdd :: Handler MyYesod ChooseRep
pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"] pageAdd = return $ chooseRep $ addHead' $ toHtmlObject ["pageAdd"]
pageDetail :: String -> Handler MyYesod ChooseRep pageDetail :: String -> Handler MyYesod ChooseRep
pageDetail s = return $ chooseRep $ toHtmlObject ["pageDetail", s] pageDetail s = return $ chooseRep $ addHead' $ toHtmlObject ["pageDetail", s]
pageDelete :: String -> Handler MyYesod HtmlObject pageDelete :: String -> Handler MyYesod (HtmlObject, HtmlObject)
pageDelete s = return $ toHtmlObject ["pageDelete", s] pageDelete s = addHead $ toHtmlObject ["pageDelete", s]
pageUpdate :: String -> Handler MyYesod ChooseRep pageUpdate :: String -> Handler MyYesod ChooseRep
pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s] pageUpdate s = return $ chooseRep $ addHead' $ toHtmlObject ["pageUpdate", s]
userInfo :: Int -> Handler MyYesod HtmlObject userInfo :: Int -> Handler MyYesod (HtmlObject, HtmlObject)
userInfo i = return $ toHtmlObject ["userInfo", show i] userInfo i = addHead $ toHtmlObject ["userInfo", show i]
userVariable :: Int -> String -> Handler MyYesod HtmlObject userVariable :: Int -> String -> Handler MyYesod (HtmlObject, HtmlObject)
userVariable i s = return $ toHtmlObject ["userVariable", show i, s] userVariable i s = addHead $ toHtmlObject ["userVariable", show i, s]
userPage :: Int -> [String] -> Handler MyYesod HtmlObject userPage :: Int -> [String] -> Handler MyYesod (HtmlObject, HtmlObject)
userPage i p = return $ toHtmlObject ["userPage", show i, show p] userPage i p = addHead $ toHtmlObject ["userPage", show i, show p]
instance Show (Verb -> Handler MyYesod ChooseRep) where instance Show (Verb -> Handler MyYesod ChooseRep) where
show _ = "verb -> handler" show _ = "verb -> handler"
@ -57,7 +63,7 @@ handler = [$resources|
ph :: [String] -> Handler MyYesod ChooseRep -> Assertion ph :: [String] -> Handler MyYesod ChooseRep -> Assertion
ph ss h = do ph ss h = do
let eh = return . chooseRep . toHtmlObject . show let eh = return . chooseRep . addHead' . toHtmlObject . show
rr = error "No raw request" rr = error "No raw request"
y = MyYesod y = MyYesod
cts = [TypeHtml] cts = [TypeHtml]

28
Yesod/Handler.hs
View File

@ -101,23 +101,28 @@ runHandler :: Handler yesod ChooseRep
-> [ContentType] -> [ContentType]
-> IO Response -> IO Response
runHandler (Handler handler) eh rr y tg cts = do runHandler (Handler handler) eh rr y tg cts = do
let toErrorHandler =
InternalError
. (show :: Control.Exception.SomeException -> String)
(headers, contents) <- Control.Exception.catch (headers, contents) <- Control.Exception.catch
(handler (rr, y, tg)) (handler (rr, y, tg))
(\e -> return ([], HCError $ InternalError $ show (\e -> return ([], HCError $ toErrorHandler e))
(e :: Control.Exception.SomeException))) let handleError e = do
case contents of
HCError e -> do
Response _ hs ct c <- runHandler (eh e) safeEh rr y tg cts Response _ hs ct c <- runHandler (eh e) safeEh rr y tg cts
let hs' = headers ++ hs let hs' = headers ++ hs
return $ Response (getStatus e) hs' ct c return $ Response (getStatus e) hs' ct c
let sendFile' ct fp = do
-- avoid lazy I/O by switching to WAI
c <- BL.readFile fp
return $ Response 200 headers ct $ cs c
case contents of
HCError e -> handleError e
HCSpecial (Redirect rt loc) -> do HCSpecial (Redirect rt loc) -> do
let hs = Header "Location" loc : headers let hs = Header "Location" loc : headers
return $ Response (getRedirectStatus rt) hs TypePlain $ cs "" return $ Response (getRedirectStatus rt) hs TypePlain $ cs ""
HCSpecial (SendFile ct fp) -> do HCSpecial (SendFile ct fp) -> Control.Exception.catch
-- FIXME do error handling on this, or leave it to the app? (sendFile' ct fp)
-- FIXME avoid lazy I/O by switching to WAI (handleError . toErrorHandler)
c <- BL.readFile fp
return $ Response 200 headers ct $ cs c
HCContent a -> do HCContent a -> do
(ct, c) <- a cts (ct, c) <- a cts
return $ Response 200 headers ct c return $ Response 200 headers ct c
@ -125,7 +130,10 @@ runHandler (Handler handler) eh rr y tg cts = do
safeEh :: ErrorResponse -> Handler yesod ChooseRep safeEh :: ErrorResponse -> Handler yesod ChooseRep
safeEh er = do safeEh er = do
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
return $ chooseRep $ toHtmlObject "Internal server error" return $ chooseRep $
( toHtmlObject $ Tag "title" [] $ cs "Internal Server Error"
, toHtmlObject "Internal server error"
)
------ Special handlers ------ Special handlers
specialResponse :: SpecialResponse -> Handler yesod a specialResponse :: SpecialResponse -> Handler yesod a

31
Yesod/Helpers/Auth.hs
View File

@ -105,7 +105,7 @@ getParam :: (Monad m, RequestReader m)
-> m ParamValue -> m ParamValue
getParam = someParam GetParam getParams getParam = someParam GetParam getParams
authOpenidForm :: Handler y HtmlObject authOpenidForm :: Handler y (HtmlObject, HtmlObject)
authOpenidForm = do authOpenidForm = do
rr <- getRawRequest rr <- getRawRequest
case getParams rr "dest" of case getParams rr "dest" of
@ -124,9 +124,9 @@ authOpenidForm = do
, EmptyTag "input" [("type", "submit"), ("value", "Login")] , EmptyTag "input" [("type", "submit"), ("value", "Login")]
] ]
] ]
return $ cs html return $ (justTitle "Log in via OpenID", cs html)
authOpenidForward :: YesodAuth y => Handler y HtmlObject authOpenidForward :: YesodAuth y => Handler y ()
authOpenidForward = do authOpenidForward = do
oid <- getParam "openid" oid <- getParam "openid"
authroot <- getFullAuthRoot authroot <- getFullAuthRoot
@ -138,7 +138,7 @@ authOpenidForward = do
(redirect RedirectTemporary) (redirect RedirectTemporary)
res res
authOpenidComplete :: YesodApproot y => Handler y HtmlObject authOpenidComplete :: YesodApproot y => Handler y ()
authOpenidComplete = do authOpenidComplete = do
ar <- getApproot ar <- getApproot
rr <- getRawRequest rr <- getRawRequest
@ -156,7 +156,7 @@ authOpenidComplete = do
redirect RedirectTemporary dest redirect RedirectTemporary dest
attempt onFailure onSuccess res attempt onFailure onSuccess res
rpxnowLogin :: YesodAuth y => Handler y HtmlObject rpxnowLogin :: YesodAuth y => Handler y ()
rpxnowLogin = do rpxnowLogin = do
ay <- getYesod ay <- getYesod
let ar = approot ay let ar = approot ay
@ -192,21 +192,30 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
Nothing -> helper xs Nothing -> helper xs
Just y -> y Just y -> y
authCheck :: Handler y HtmlObject -- FIXME use templates for all of the following
justTitle :: String -> HtmlObject
justTitle = cs . Tag "title" [] . cs
authCheck :: Handler y (HtmlObject, HtmlObject)
authCheck = do authCheck = do
ident <- maybeIdentifier ident <- maybeIdentifier
dn <- displayName dn <- displayName
return $ toHtmlObject return $ (justTitle "Authentication Status", toHtmlObject
[ ("identifier", fromMaybe "" ident) [ ("identifier", fromMaybe "" ident)
, ("displayName", fromMaybe "" dn) , ("displayName", fromMaybe "" dn)
] ])
authLogout :: YesodAuth y => Handler y HtmlObject authLogout :: YesodAuth y => Handler y ()
authLogout = do authLogout = do
deleteCookie authCookieName deleteCookie authCookieName
rr <- getRawRequest
ar <- getApproot ar <- getApproot
redirect RedirectTemporary ar let dest = case cookies rr "DEST" of
-- FIXME check the DEST information [] -> ar
(x:_) -> x
deleteCookie "DEST"
redirect RedirectTemporary dest
-- | Gets the identifier for a user if available. -- | Gets the identifier for a user if available.
maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String)

4
Yesod/Helpers/Static.hs
View File

@ -22,15 +22,13 @@ module Yesod.Helpers.Static
, fileLookupDir , fileLookupDir
) where ) where
import qualified Data.ByteString.Lazy as B
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import Control.Monad import Control.Monad
import Yesod import Yesod
import Data.List (intercalate) import Data.List (intercalate)
-- FIXME this type is getting ugly... type FileLookup = FilePath -> IO (Maybe (Either FilePath Content))
type FileLookup = FilePath -> IO (Maybe (Either FilePath B.ByteString))
-- | A 'FileLookup' for files in a directory. Note that this function does not -- | A 'FileLookup' for files in a directory. Note that this function does not
-- check if the requested path does unsafe things, eg expose hidden files. You -- check if the requested path does unsafe things, eg expose hidden files. You

2
Yesod/Request.hs
View File

@ -74,7 +74,7 @@ parseEnv = rawEnv `fmap` getRawRequest
data RawRequest = RawRequest data RawRequest = RawRequest
{ rawGetParams :: [(ParamName, ParamValue)] { rawGetParams :: [(ParamName, ParamValue)]
, rawCookies :: [(ParamName, ParamValue)] , rawCookies :: [(ParamName, ParamValue)]
-- FIXME when we switch to WAI, the following two should be combined and -- when we switch to WAI, the following two should be combined and
-- wrapped in the IO monad -- wrapped in the IO monad
, rawPostParams :: [(ParamName, ParamValue)] , rawPostParams :: [(ParamName, ParamValue)]
, rawFiles :: [(ParamName, FileInfo String BL.ByteString)] , rawFiles :: [(ParamName, FileInfo String BL.ByteString)]

3
Yesod/Response.hs
View File

@ -124,8 +124,7 @@ instance HasReps [(ContentType, Content)] where
(x:_) -> x (x:_) -> x
_ -> error "chooseRep [(ContentType, Content)] of empty" _ -> error "chooseRep [(ContentType, Content)] of empty"
-- FIXME remove this instance? only good for debugging, maybe special debugging newtype? instance HasReps (HtmlObject, HtmlObject) where
instance HasReps HtmlObject where
chooseRep = defChooseRep chooseRep = defChooseRep
[ (TypeHtml, return . cs . unHtmlDoc . cs) [ (TypeHtml, return . cs . unHtmlDoc . cs)
, (TypeJson, return . cs . unJsonDoc . cs) , (TypeJson, return . cs . unJsonDoc . cs)

3
Yesod/Template.hs
View File

@ -1,3 +1,4 @@
-- FIXME this whole module needs to be rethought
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module Yesod.Template module Yesod.Template
@ -24,7 +25,6 @@ type TemplateGroup = STGroup Text
class HasTemplateGroup a where class HasTemplateGroup a where
getTemplateGroup :: a TemplateGroup getTemplateGroup :: a TemplateGroup
-- FIXME better home
template :: (MonadFailure NoSuchTemplate t, HasTemplateGroup t) template :: (MonadFailure NoSuchTemplate t, HasTemplateGroup t)
=> String -- ^ template name => String -- ^ template name
-> String -- ^ object name -> String -- ^ object name
@ -58,7 +58,6 @@ instance HasReps Template where
return $ cs $ unJsonDoc $ cs ho) return $ cs $ unJsonDoc $ cs ho)
] ]
-- FIXME
data TemplateFile = TemplateFile FilePath HtmlObject data TemplateFile = TemplateFile FilePath HtmlObject
instance HasReps TemplateFile where instance HasReps TemplateFile where
chooseRep = defChooseRep [ (TypeHtml, chooseRep = defChooseRep [ (TypeHtml,

24
Yesod/Yesod.hs
View File

@ -6,7 +6,7 @@ module Yesod.Yesod
, toHackApp , toHackApp
) where ) where
import Data.Object.Html (toHtmlObject) import Data.Object.Html
import Yesod.Response import Yesod.Response
import Yesod.Request import Yesod.Request
import Yesod.Definitions import Yesod.Definitions
@ -14,7 +14,6 @@ import Yesod.Handler
import Yesod.Template (TemplateGroup) import Yesod.Template (TemplateGroup)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Convertible.Text
import Text.StringTemplate import Text.StringTemplate
import Web.Mime import Web.Mime
import Web.Encodings (parseHttpAccept) import Web.Encodings (parseHttpAccept)
@ -55,23 +54,32 @@ class Yesod a => YesodApproot a where
getApproot :: YesodApproot y => Handler y Approot getApproot :: YesodApproot y => Handler y Approot
getApproot = approot `fmap` getYesod getApproot = approot `fmap` getYesod
justTitle :: String -> HtmlObject
justTitle = cs . Tag "title" [] . cs
defaultErrorHandler :: Yesod y defaultErrorHandler :: Yesod y
=> ErrorResponse => ErrorResponse
-> Handler y ChooseRep -> Handler y ChooseRep
defaultErrorHandler NotFound = do defaultErrorHandler NotFound = do
rr <- getRawRequest rr <- getRawRequest
return $ chooseRep $ toHtmlObject $ "Not found: " ++ show rr return $ chooseRep
( justTitle "Not Found"
, toHtmlObject [("Not found", show rr)]
)
defaultErrorHandler PermissionDenied = defaultErrorHandler PermissionDenied =
return $ chooseRep $ toHtmlObject "Permission denied" return $ chooseRep
( justTitle "Permission Denied"
, toHtmlObject "Permission denied"
)
defaultErrorHandler (InvalidArgs ia) = defaultErrorHandler (InvalidArgs ia) =
return $ chooseRep $ toHtmlObject return $ chooseRep (justTitle "Invalid Arguments", toHtmlObject
[ ("errorMsg", toHtmlObject "Invalid arguments") [ ("errorMsg", toHtmlObject "Invalid arguments")
, ("messages", toHtmlObject ia) , ("messages", toHtmlObject ia)
] ])
defaultErrorHandler (InternalError e) = defaultErrorHandler (InternalError e) =
return $ chooseRep $ toHtmlObject return $ chooseRep (justTitle "Internal Server Error", toHtmlObject
[ ("Internal server error", e) [ ("Internal server error", e)
] ])
toHackApp :: Yesod y => y -> IO Hack.Application toHackApp :: Yesod y => y -> IO Hack.Application
toHackApp a = do toHackApp a = do