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 FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
-- | An 'Html' data type and associated 'ConvertSuccess' instances. This has
-- useful conversions in web development:
--
@ -66,6 +65,17 @@ newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text }
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 = cs
@ -78,11 +88,6 @@ instance ConvertSuccess TS.Text Html where
convertSuccess = Text
instance ConvertSuccess Text Html where
convertSuccess = Text . cs
$(deriveAttempts
[ (''String, ''Html)
, (''Text, ''Html)
, (''TS.Text, ''Html)
])
instance ConvertSuccess String HtmlObject where
convertSuccess = Scalar . cs
@ -151,11 +156,19 @@ cdata h = HtmlList
, Html $ cs "]]>"
]
instance ConvertSuccess Html HtmlDoc where
convertSuccess h = HtmlDoc $ TL.fromChunks $
cs "<!DOCTYPE html>\n<html><head><title>HtmlDoc (autogenerated)</title></head><body>"
: htmlToText False h
[cs "</body></html>"]
instance ConvertSuccess (Html, Html) HtmlDoc where
convertSuccess (h, b) = HtmlDoc $ TL.fromChunks $
cs "<!DOCTYPE html>\n"
: htmlToText False (Tag "html" [] $ HtmlList
[ 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
convertSuccess (Scalar h) = h
@ -169,25 +182,20 @@ instance ConvertSuccess HtmlObject Html where
, Tag "dd" [] $ cs v
]
instance ConvertSuccess HtmlObject HtmlDoc where
convertSuccess = cs . (cs :: HtmlObject -> Html)
instance ConvertSuccess Html JsonScalar where
convertSuccess = cs . unHtmlFragment . cs
instance ConvertAttempt Html JsonScalar where
convertAttempt = return . cs
instance ConvertSuccess HtmlObject JsonObject where
convertSuccess = mapKeysValues convertSuccess convertSuccess
instance ConvertAttempt HtmlObject JsonObject where
convertAttempt = return . cs
instance ConvertSuccess HtmlObject JsonDoc where
convertSuccess = cs . (cs :: HtmlObject -> JsonObject)
$(deriveAttempts
[ (''Html, ''HtmlFragment)
, (''Html, ''HtmlDoc)
, (''Html, ''JsonScalar)
])
$(deriveSuccessConvs ''String ''Html
[''String, ''Text]
[''Html, ''HtmlFragment])
instance ConvertAttempt HtmlObject JsonDoc where
convertAttempt = return . cs
instance ToSElem HtmlObject where
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?
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.Providers.HUnit
import Test.HUnit hiding (Test)
import Control.Applicative
data Errors = Errors
instance Yesod Errors where
@ -28,19 +27,19 @@ instance YesodAuth Errors
denied :: Handler Errors ()
denied = permissionDenied
needsIdent :: Handler Errors HtmlObject
needsIdent :: Handler Errors (HtmlObject, HtmlObject)
needsIdent = do
i <- authIdentifier
return $ toHtmlObject i
return $ (toHtmlObject "", toHtmlObject i)
hasArgs :: Handler Errors HtmlObject
hasArgs :: Handler Errors (HtmlObject, HtmlObject)
hasArgs = do
{- FIXME wait for new request API
(a, b) <- runRequest $ (,) <$> getParam "firstParam"
<*> getParam "secondParam"
-}
let (a, b) = ("foo", "bar")
return $ toHtmlObject [a :: String, b]
return (toHtmlObject "", toHtmlObject [a :: String, b])
caseErrorMessages :: Assertion
caseErrorMessages = do

38
Test/QuasiResource.hs
View File

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

28
Yesod/Handler.hs
View File

@ -101,23 +101,28 @@ runHandler :: Handler yesod ChooseRep
-> [ContentType]
-> IO Response
runHandler (Handler handler) eh rr y tg cts = do
let toErrorHandler =
InternalError
. (show :: Control.Exception.SomeException -> String)
(headers, contents) <- Control.Exception.catch
(handler (rr, y, tg))
(\e -> return ([], HCError $ InternalError $ show
(e :: Control.Exception.SomeException)))
case contents of
HCError e -> do
(\e -> return ([], HCError $ toErrorHandler e))
let handleError e = do
Response _ hs ct c <- runHandler (eh e) safeEh rr y tg cts
let hs' = headers ++ hs
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
let hs = Header "Location" loc : headers
return $ Response (getRedirectStatus rt) hs TypePlain $ cs ""
HCSpecial (SendFile ct fp) -> do
-- FIXME do error handling on this, or leave it to the app?
-- FIXME avoid lazy I/O by switching to WAI
c <- BL.readFile fp
return $ Response 200 headers ct $ cs c
HCSpecial (SendFile ct fp) -> Control.Exception.catch
(sendFile' ct fp)
(handleError . toErrorHandler)
HCContent a -> do
(ct, c) <- a cts
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 er = do
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
specialResponse :: SpecialResponse -> Handler yesod a

31
Yesod/Helpers/Auth.hs
View File

@ -105,7 +105,7 @@ getParam :: (Monad m, RequestReader m)
-> m ParamValue
getParam = someParam GetParam getParams
authOpenidForm :: Handler y HtmlObject
authOpenidForm :: Handler y (HtmlObject, HtmlObject)
authOpenidForm = do
rr <- getRawRequest
case getParams rr "dest" of
@ -124,9 +124,9 @@ authOpenidForm = do
, 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
oid <- getParam "openid"
authroot <- getFullAuthRoot
@ -138,7 +138,7 @@ authOpenidForward = do
(redirect RedirectTemporary)
res
authOpenidComplete :: YesodApproot y => Handler y HtmlObject
authOpenidComplete :: YesodApproot y => Handler y ()
authOpenidComplete = do
ar <- getApproot
rr <- getRawRequest
@ -156,7 +156,7 @@ authOpenidComplete = do
redirect RedirectTemporary dest
attempt onFailure onSuccess res
rpxnowLogin :: YesodAuth y => Handler y HtmlObject
rpxnowLogin :: YesodAuth y => Handler y ()
rpxnowLogin = do
ay <- getYesod
let ar = approot ay
@ -192,21 +192,30 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
Nothing -> helper xs
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
ident <- maybeIdentifier
dn <- displayName
return $ toHtmlObject
return $ (justTitle "Authentication Status", toHtmlObject
[ ("identifier", fromMaybe "" ident)
, ("displayName", fromMaybe "" dn)
]
])
authLogout :: YesodAuth y => Handler y HtmlObject
authLogout :: YesodAuth y => Handler y ()
authLogout = do
deleteCookie authCookieName
rr <- getRawRequest
ar <- getApproot
redirect RedirectTemporary ar
-- FIXME check the DEST information
let dest = case cookies rr "DEST" of
[] -> ar
(x:_) -> x
deleteCookie "DEST"
redirect RedirectTemporary dest
-- | Gets the identifier for a user if available.
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
) where
import qualified Data.ByteString.Lazy as B
import System.Directory (doesFileExist)
import Control.Monad
import Yesod
import Data.List (intercalate)
-- FIXME this type is getting ugly...
type FileLookup = FilePath -> IO (Maybe (Either FilePath B.ByteString))
type FileLookup = FilePath -> IO (Maybe (Either FilePath Content))
-- | 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

2
Yesod/Request.hs
View File

@ -74,7 +74,7 @@ parseEnv = rawEnv `fmap` getRawRequest
data RawRequest = RawRequest
{ rawGetParams :: [(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
, rawPostParams :: [(ParamName, ParamValue)]
, rawFiles :: [(ParamName, FileInfo String BL.ByteString)]

3
Yesod/Response.hs
View File

@ -124,8 +124,7 @@ instance HasReps [(ContentType, Content)] where
(x:_) -> x
_ -> error "chooseRep [(ContentType, Content)] of empty"
-- FIXME remove this instance? only good for debugging, maybe special debugging newtype?
instance HasReps HtmlObject where
instance HasReps (HtmlObject, HtmlObject) where
chooseRep = defChooseRep
[ (TypeHtml, return . cs . unHtmlDoc . 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 FlexibleContexts #-}
module Yesod.Template
@ -24,7 +25,6 @@ type TemplateGroup = STGroup Text
class HasTemplateGroup a where
getTemplateGroup :: a TemplateGroup
-- FIXME better home
template :: (MonadFailure NoSuchTemplate t, HasTemplateGroup t)
=> String -- ^ template name
-> String -- ^ object name
@ -58,7 +58,6 @@ instance HasReps Template where
return $ cs $ unJsonDoc $ cs ho)
]
-- FIXME
data TemplateFile = TemplateFile FilePath HtmlObject
instance HasReps TemplateFile where
chooseRep = defChooseRep [ (TypeHtml,

24
Yesod/Yesod.hs
View File

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