diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs
index 32938049..369e4a23 100644
--- a/Data/Object/Html.hs
+++ b/Data/Object/Html.hs
@@ -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 "\nHtmlDoc (autogenerated)"
- : htmlToText False h
- [cs ""]
+instance ConvertSuccess (Html, Html) HtmlDoc where
+ convertSuccess (h, b) = HtmlDoc $ TL.fromChunks $
+ cs "\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
diff --git a/TODO b/TODO
index a44ffdf5..6a6c07d0 100644
--- a/TODO
+++ b/TODO
@@ -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
diff --git a/Test/Errors.hs b/Test/Errors.hs
index 0861a5de..ddb07346 100644
--- a/Test/Errors.hs
+++ b/Test/Errors.hs
@@ -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
diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs
index 43ac1495..4a4439d3 100644
--- a/Test/QuasiResource.hs
+++ b/Test/QuasiResource.hs
@@ -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]
diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs
index c1a6bb9d..68f7d32c 100644
--- a/Yesod/Handler.hs
+++ b/Yesod/Handler.hs
@@ -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
diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs
index 332185ae..9fcefe62 100644
--- a/Yesod/Helpers/Auth.hs
+++ b/Yesod/Helpers/Auth.hs
@@ -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)
diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs
index 83a98fc0..647ae240 100644
--- a/Yesod/Helpers/Static.hs
+++ b/Yesod/Helpers/Static.hs
@@ -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
diff --git a/Yesod/Request.hs b/Yesod/Request.hs
index cbe02d6f..6b730a55 100644
--- a/Yesod/Request.hs
+++ b/Yesod/Request.hs
@@ -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)]
diff --git a/Yesod/Response.hs b/Yesod/Response.hs
index d2bdbc3d..23a27fb1 100644
--- a/Yesod/Response.hs
+++ b/Yesod/Response.hs
@@ -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)
diff --git a/Yesod/Template.hs b/Yesod/Template.hs
index b145d95d..a13db2fa 100644
--- a/Yesod/Template.hs
+++ b/Yesod/Template.hs
@@ -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,
diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs
index e77e7864..f6cb4bf2 100644
--- a/Yesod/Yesod.hs
+++ b/Yesod/Yesod.hs
@@ -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