Refactored and documented Response and Handler

2009-09-21 22:21:21 +03:00 · 2009-09-21 22:21:21 +03:00 · 0519b99fed
commit 0519b99fed
parent 2a958c1a8f
8 changed files with 230 additions and 212 deletions
--- a/Web/Restful/Application.hs
+++ b/Web/Restful/Application.hs
@ -65,14 +65,14 @@ class ResourceName a b => RestfulApp a b | a -> b where
    responseWrapper _ _ = return

    -- | Output error response pages.
-    errorHandler :: a -> RawRequest -> ErrorResult -> HasRepsW
-    errorHandler _ rr NotFound = HasRepsW $ toObject $ "Not found: " ++ show rr
+    errorHandler :: a -> RawRequest -> ErrorResult -> Reps
+    errorHandler _ rr NotFound = reps $ toObject $ "Not found: " ++ show rr
    errorHandler _ _ (Redirect url) =
-        HasRepsW $ toObject $ "Redirect to: " ++ url
+        reps $ toObject $ "Redirect to: " ++ url
    errorHandler _ _ (InternalError e) =
-        HasRepsW $ toObject $ "Internal server error: " ++ e
+        reps $ toObject $ "Internal server error: " ++ e
    errorHandler _ _ (InvalidArgs ia) =
-        HasRepsW $ toObject $
+        reps $ toObject $
            [ ("errorMsg", toObject "Invalid arguments")
            , ("messages", toObject ia)
            ]
@ -118,7 +118,7 @@ toHackApplication sampleRN hm env = do
    let (Right resource) = splitPath $ Hack.pathInfo env
    let (handler, urlParams') =
          case findResourceNames resource of
-            [] -> (noHandler, [])
+            [] -> (notFound, [])
            [(rn, urlParams'')] ->
                let verb = toVerb $ Hack.requestMethod env
                 in (hm rn verb, urlParams'')
@ -126,7 +126,7 @@ toHackApplication sampleRN hm env = do
    let rr = envToRawRequest urlParams' env
    let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
        ctypes' = parseHttpAccept rawHttpAccept
-    runResponse (errorHandler sampleRN rr)
+    runHandler (errorHandler sampleRN rr)
                (responseWrapper sampleRN)
                ctypes'
                handler
--- a/Web/Restful/Handler.hs
+++ b/Web/Restful/Handler.hs
@ -1,6 +1,8 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Restful.Handler
@ -15,22 +17,133 @@
 --
 ---------------------------------------------------------
 module Web.Restful.Handler
-    ( Handler
-    , liftHandler
-    , noHandler
+    ( -- * Handler monad
+      HandlerT
+    , HandlerIO
+    , Handler
+    , runHandler
+    , getRequest
+    , liftIO
+      -- * Special handlers
+    , redirect
+    , notFound
+      -- * Setting headers
+    , addCookie
+    , deleteCookie
+    , header
    ) where

 import Web.Restful.Request
 import Web.Restful.Response

-type Handler = Response -- FIXME maybe move some stuff around now...
+import Control.Monad.Trans
+import Control.Monad (liftM)

-liftHandler :: (Request req, HasReps rep)
-            => (req -> ResponseIO rep)
+import Data.Maybe (fromJust)
+import qualified Data.ByteString.Lazy as B
+import qualified Hack
+
+------ Handler monad
+newtype HandlerT m a =
+    HandlerT (RawRequest -> m (Either ErrorResult a, [Header]))
+type HandlerIO = HandlerT IO
+type Handler = HandlerIO Reps
+
+runHandler :: (ErrorResult -> Reps)
+            -> (ContentType -> B.ByteString -> IO B.ByteString)
+            -> [ContentType]
            -> Handler
-liftHandler f = do
-    req <- getRequest
-    wrapResponse $ f req
+            -> RawRequest
+            -> IO Hack.Response
+runHandler eh wrapper ctypesAll (HandlerT inside) rr = do
+    (x, headers') <- inside rr
+    let extraHeaders =
+            case x of
+                Left r -> getHeaders r
+                Right _ -> []
+    headers <- mapM toPair (headers' ++ extraHeaders)
+    let outReps = either (reps . eh) reps x
+    let statusCode =
+            case x of
+                Left r -> getStatus r
+                Right _ -> 200
+    (ctype, selectedRep) <- chooseRep outReps ctypesAll
+    finalRep <- wrapper ctype selectedRep
+    let headers'' = ("Content-Type", ctype) : headers
+    return $! Hack.Response statusCode headers'' finalRep

-noHandler :: Handler
-noHandler = notFound
+chooseRep :: Monad m
+          => [(ContentType, B.ByteString)]
+          -> [ContentType]
+          -> m (ContentType, B.ByteString)
+chooseRep rs cs
+  | length rs == 0 = fail "All reps must have at least one value"
+  | otherwise = do
+    let availCs = map fst rs
+    case filter (`elem` availCs) cs of
+        [] -> return $ head rs
+        [ctype] -> return (ctype, fromJust $ lookup ctype rs)
+        _ -> fail "Overlapping representations"
+
+instance MonadTrans HandlerT where
+    lift ma = HandlerT $ const $ do
+        a <- ma
+        return (Right a, [])
+
+instance MonadIO HandlerIO where
+    liftIO = lift
+
+instance Monad m => Functor (HandlerT m) where
+    fmap = liftM
+
+instance Monad m => Monad (HandlerT m) where
+    return = lift . return
+    fail s = HandlerT (const $ return (Left $ InternalError s, []))
+    (HandlerT mx) >>= f = HandlerT $ \rr -> do
+        (x, hs1) <- mx rr
+        case x of
+            Left x' -> return (Left x', hs1)
+            Right a -> do
+                let (HandlerT b') = f a
+                (b, hs2) <- b' rr
+                return (b, hs1 ++ hs2)
+
+-- | Parse a request in the Handler monad. On failure, return a 400 error.
+getRequest :: (Monad m, Request r) => HandlerT m r
+getRequest = HandlerT $ \rr -> return (helper rr, []) where
+    helper :: Request r
+           => RawRequest
+           -> Either ErrorResult r
+    helper rr =
+        case runRequestParser parseRequest rr of
+            Left errors -> Left $ InvalidArgs errors
+            Right r -> Right r
+
+------ Special handlers
+-- | Redirect to the given URL.
+redirect :: Monad m => String -> HandlerT m a
+redirect s = HandlerT (const $ return (Left $ Redirect s, []))
+
+-- | Return a 404 not found page. Also denotes no handler available.
+notFound :: Monad m => HandlerT m a
+notFound = HandlerT (const $ return (Left NotFound, []))
+
+------- Headers
+-- | Set the cookie on the client.
+addCookie :: Monad m
+          => Int -- ^ minutes to timeout
+          -> String -- ^ key
+          -> String -- ^ value
+          -> HandlerT m ()
+addCookie a b c = addHeader $ AddCookie a b c
+
+-- | Unset the cookie on the client.
+deleteCookie :: Monad m => String -> HandlerT m ()
+deleteCookie = addHeader . DeleteCookie
+
+-- | Set an arbitrary header on the client.
+header :: Monad m => String -> String -> HandlerT m ()
+header a b = addHeader $ Header a b
+
+addHeader :: Monad m => Header -> HandlerT m ()
+addHeader h = HandlerT (const $ return (Right (), [h]))
--- a/Web/Restful/Helpers/Auth.hs
+++ b/Web/Restful/Helpers/Auth.hs
@ -28,7 +28,6 @@ import Web.Restful.Constants
 import Control.Applicative ((<$>), Applicative (..))
 import Control.Monad.Reader

-import Data.Object
 import Data.Maybe (fromMaybe)

 data AuthResource =
@ -42,13 +41,13 @@ data AuthResource =

 type RpxnowApiKey = String -- FIXME newtype
 instance ResourceName AuthResource (Maybe RpxnowApiKey) where
-    getHandler _ Check Get = liftHandler authCheck
-    getHandler _ Logout Get = liftHandler authLogout
-    getHandler _ Openid Get = liftHandler authOpenidForm
-    getHandler _ OpenidForward Get = liftHandler authOpenidForward
-    getHandler _ OpenidComplete Get = liftHandler authOpenidComplete
-    getHandler (Just key) LoginRpxnow Get = liftHandler $ rpxnowLogin key
-    getHandler _ _ _ = noHandler
+    getHandler _ Check Get = authCheck
+    getHandler _ Logout Get = authLogout
+    getHandler _ Openid Get = authOpenidForm
+    getHandler _ OpenidForward Get = authOpenidForward
+    getHandler _ OpenidComplete Get = authOpenidComplete
+    getHandler (Just key) LoginRpxnow Get = rpxnowLogin key
+    getHandler _ _ _ = notFound

    allValues =
        Check
@ -75,8 +74,9 @@ instance Show OIDFormReq where
    show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++
                                 "</p>"

-authOpenidForm :: OIDFormReq -> ResponseIO GenResponse
-authOpenidForm m@(OIDFormReq _ dest) = do
+authOpenidForm :: Handler
+authOpenidForm = do
+    m@(OIDFormReq _ dest) <- getRequest
    let html =
            show m ++
            "<form method='get' action='forward/'>" ++
@ -86,7 +86,7 @@ authOpenidForm m@(OIDFormReq _ dest) = do
    case dest of
        Just dest' -> addCookie 20 "DEST" dest'
        Nothing -> return ()
-    return $! htmlResponse html
+    htmlResponse html

 data OIDFReq = OIDFReq String String
 instance Request OIDFReq where
@ -97,8 +97,9 @@ instance Request OIDFReq where
                       show (Hack.serverPort env) ++
                       "/auth/openid/complete/"
        return $! OIDFReq oid complete
-authOpenidForward :: OIDFReq -> Response
-authOpenidForward (OIDFReq oid complete) = do
+authOpenidForward :: Handler
+authOpenidForward = do
+    OIDFReq oid complete <- getRequest
    res <- liftIO $ OpenId.getForwardUrl oid complete
    case res of
        Left err -> redirect $ "/auth/openid/?message="
@ -113,8 +114,9 @@ instance Request OIDComp where
        dest <- cookieParam "DEST"
        return $! OIDComp gets dest

-authOpenidComplete :: OIDComp -> Response
-authOpenidComplete (OIDComp gets' dest) = do
+authOpenidComplete :: Handler
+authOpenidComplete = do
+    OIDComp gets' dest <- getRequest
    res <- liftIO $ OpenId.authenticate gets'
    case res of
      Left err -> redirect $ "/auth/openid/?message="
@ -137,9 +139,9 @@ chopHash ('#':rest) = rest
 chopHash x = x

 rpxnowLogin :: String -- ^ api key
-            -> RpxnowRequest
-            -> Response
-rpxnowLogin apiKey (RpxnowRequest token dest') = do
+            -> Handler
+rpxnowLogin apiKey = do
+    RpxnowRequest token dest' <- getRequest
    let dest = case dest' of
                Nothing -> "/"
                Just "" -> "/"
@ -154,16 +156,17 @@ data AuthRequest = AuthRequest (Maybe String)
 instance Request AuthRequest where
    parseRequest = AuthRequest `fmap` identifier

-authCheck :: AuthRequest -> ResponseIO Object
-authCheck (AuthRequest Nothing) =
-    return $ toObject [("status", "notloggedin")]
-authCheck (AuthRequest (Just i)) =
-    return $ toObject
-        [ ("status", "loggedin")
-        , ("ident", i)
-        ]
+authCheck :: Handler
+authCheck = do
+    req <- getRequest
+    case req of
+        AuthRequest Nothing -> objectResponse[("status", "notloggedin")]
+        AuthRequest (Just i) -> objectResponse
+            [ ("status", "loggedin")
+            , ("ident", i)
+            ]

-authLogout :: () -> ResponseIO Object
-authLogout _ = do
+authLogout :: Handler
+authLogout = do
    deleteCookie authCookieName
-    return $ toObject [("status", "loggedout")]
+    objectResponse [("status", "loggedout")]
--- a/Web/Restful/Helpers/Static.hs
+++ b/Web/Restful/Helpers/Static.hs
@ -25,19 +25,20 @@ import Web.Restful
 type FileLookup = FilePath -> IO (Maybe B.ByteString)

 serveStatic :: FileLookup -> Verb -> Handler
-serveStatic fl Get = liftHandler $ getStatic fl
-serveStatic _ _ = noHandler
+serveStatic fl Get = getStatic fl
+serveStatic _ _ = notFound

 newtype StaticReq = StaticReq FilePath
 instance Request StaticReq where
    parseRequest = StaticReq `fmap` urlParam "filepath" -- FIXME check for ..

-getStatic :: FileLookup -> StaticReq -> ResponseIO GenResponse
-getStatic fl (StaticReq fp) = do
+getStatic :: FileLookup -> Handler
+getStatic fl = do
+    StaticReq fp <- getRequest
    content <- liftIO $ fl fp
    case content of
        Nothing -> notFound
-        Just bs -> return $ byteStringResponse (mimeType $ ext fp) bs
+        Just bs -> genResponse (mimeType $ ext fp) bs

 mimeType :: String -> String
 mimeType "jpg" = "image/jpeg"
--- a/Web/Restful/Response.hs
+++ b/Web/Restful/Response.hs
@ -1,6 +1,4 @@
-{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Restful.Response
@ -15,45 +13,36 @@
 --
 ---------------------------------------------------------
 module Web.Restful.Response
-    ( formatW3
+    ( -- * Representations
+      Reps
    , HasReps (..)
-    , notFound
-    , wrapResponse
-    , ResponseIO
-    , ResponseT
-    , Response
-    , runResponse
-    , deleteCookie
-    , redirect
-    , addCookie
-    , header
-    , GenResponse (..)
-    , liftIO
+    , ContentType
+      -- * Abnormal responses
    , ErrorResult (..)
-    , HasRepsW (..)
-    , byteStringResponse
+    , getHeaders
+    , getStatus
+      -- * Header
+    , Header (..)
+    , toPair
+      -- * Generic responses
+    , response
+    , genResponse
    , htmlResponse
-    , getRequest
+    , objectResponse
    ) where

 import Data.ByteString.Class
-import Data.Time.Format
 import Data.Time.Clock
-import System.Locale
 import Data.Object
 import qualified Data.ByteString.Lazy as B
 import Data.Object.Instances
-import Data.Maybe (fromJust)

-import Web.Restful.Request
-
-import Control.Monad.Trans
-import Control.Monad (liftM)
-
-import qualified Hack
+import Web.Restful.Utils (formatW3)

 type ContentType = String

+type Reps = [(ContentType, B.ByteString)]
+
 -- | Something which can be represented as multiple content types.
 -- Each content type is called a representation of the data.
 class HasReps a where
@ -61,14 +50,9 @@ class HasReps a where
    -- content type. If the user asked for a specific response type (like
    -- text/html), then that will get priority. If not, then the first
    -- element in this list will be used.
-    reps :: a -> [(ContentType, B.ByteString)]
-
-- | Wrap up any instance of 'HasReps'.
-data HasRepsW = forall a. HasReps a => HasRepsW a
-
-instance HasReps HasRepsW where
-    reps (HasRepsW r) = reps r
+    reps :: a -> Reps

+-- | Abnormal return codes.
 data ErrorResult =
    Redirect String
    | NotFound
@ -85,47 +69,14 @@ getHeaders :: ErrorResult -> [Header]
 getHeaders (Redirect s) = [Header "Location" s]
 getHeaders _ = []

-newtype ResponseT m a =
-    ResponseT (RawRequest -> m (Either ErrorResult a, [Header]))
-type ResponseIO = ResponseT IO
-type Response = ResponseIO HasRepsW
-
-runResponse :: (ErrorResult -> HasRepsW)
-            -> (ContentType -> B.ByteString -> IO B.ByteString)
-            -> [ContentType]
-            -> Response
-            -> RawRequest
-            -> IO Hack.Response
-runResponse eh wrapper ctypesAll (ResponseT inside) rr = do
-    (x, headers') <- inside rr
-    let extraHeaders =
-            case x of
-                Left r -> getHeaders r
-                Right _ -> []
-    headers <- mapM toPair (headers' ++ extraHeaders)
-    let outReps = either (reps . eh) reps x
-    let statusCode =
-            case x of
-                Left r -> getStatus r
-                Right _ -> 200
-    (ctype, selectedRep) <- chooseRep outReps ctypesAll
-    finalRep <- wrapper ctype selectedRep
-    let headers'' = ("Content-Type", ctype) : headers
-    return $! Hack.Response statusCode headers'' finalRep
-
-chooseRep :: Monad m
-          => [(ContentType, B.ByteString)]
-          -> [ContentType]
-          -> m (ContentType, B.ByteString)
-chooseRep rs cs
-  | length rs == 0 = fail "All reps must have at least one value"
-  | otherwise = do
-    let availCs = map fst rs
-    case filter (`elem` availCs) cs of
-        [] -> return $ head rs
-        [ctype] -> return (ctype, fromJust $ lookup ctype rs)
-        _ -> fail "Overlapping representations"
+----- header stuff
+-- | Headers to be added to a 'Result'.
+data Header =
+    AddCookie Int String String
+    | DeleteCookie String
+    | Header String String

+-- | Convert Header to a key/value pair.
 toPair :: Header -> IO (String, String)
 toPair (AddCookie minutes key value) = do
    now <- getCurrentTime
@ -137,78 +88,29 @@ toPair (DeleteCookie key) = return
     key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
 toPair (Header key value) = return (key, value)

-wrapResponse :: (Monad m, HasReps rep)
-             => ResponseT m rep
-             -> ResponseT m HasRepsW
-wrapResponse = fmap HasRepsW
+------ Generic responses
+-- | Lifts a 'HasReps' into a monad.
+response :: (Monad m, HasReps reps) => reps -> m Reps
+response = return . reps

-instance MonadTrans ResponseT where
-    lift ma = ResponseT $ const $ do
-        a <- ma
-        return (Right a, [])
+-- | Return a response with an arbitrary content type.
+genResponse :: (Monad m, LazyByteString lbs)
+            => ContentType
+            -> lbs
+            -> m Reps
+genResponse ct lbs = return [(ct, toLazyByteString lbs)]

-instance MonadIO ResponseIO where
-    liftIO = lift
+-- | Return a response with a text/html content type.
+htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps
+htmlResponse = genResponse "text/html"

-redirect :: Monad m => String -> ResponseT m a
-redirect s = ResponseT (const $ return (Left $ Redirect s, []))
-
-notFound :: Monad m => ResponseT m a
-notFound = ResponseT (const $ return (Left NotFound, []))
-
-instance Monad m => Functor (ResponseT m) where
-    fmap = liftM
-
-instance Monad m => Monad (ResponseT m) where
-    return = lift . return
-    fail s = ResponseT (const $ return (Left $ InternalError s, []))
-    (ResponseT mx) >>= f = ResponseT $ \rr -> do
-        (x, hs1) <- mx rr
-        case x of
-            Left x' -> return (Left x', hs1)
-            Right a -> do
-                let (ResponseT b') = f a
-                (b, hs2) <- b' rr
-                return (b, hs1 ++ hs2)
-
-- | Headers to be added to a 'Result'.
-data Header =
-    AddCookie Int String String
-    | DeleteCookie String
-    | Header String String
-
-addCookie :: Monad m => Int -> String -> String -> ResponseT m ()
-addCookie a b c = addHeader $ AddCookie a b c
-
-deleteCookie :: Monad m => String -> ResponseT m ()
-deleteCookie = addHeader . DeleteCookie
-
-header :: Monad m => String -> String -> ResponseT m ()
-header a b = addHeader $ Header a b
-
-addHeader :: Monad m => Header -> ResponseT m ()
-addHeader h = ResponseT (const $ return (Right (), [h]))
+-- | Return a response from an Object.
+objectResponse :: (Monad m, ToObject o) => o -> m Reps
+objectResponse = return . reps . toObject

+-- HasReps instances
 instance HasReps () where
    reps _ = [("text/plain", toLazyByteString "")]
-
-data GenResponse = HtmlResponse B.ByteString
-                 | ObjectResponse Object
-                 | HtmlOrObjectResponse String Object
-                 | ByteStringResponse ContentType B.ByteString
-instance HasReps GenResponse where
-    reps (HtmlResponse h) = [("text/html", toLazyByteString h)]
-    reps (ObjectResponse t) = reps t
-    reps (HtmlOrObjectResponse h t) =
-        ("text/html", toLazyByteString h) : reps t
-    reps (ByteStringResponse ct con) = [(ct, con)]
-
-byteStringResponse :: LazyByteString lbs => ContentType -> lbs -> GenResponse
-byteStringResponse ct = ByteStringResponse ct . toLazyByteString
-
-htmlResponse :: LazyByteString lbs => lbs -> GenResponse
-htmlResponse = HtmlResponse . toLazyByteString
-
 instance HasReps Object where
    reps o =
        [ ("text/html", unHtml $ safeFromObject o)
@ -218,17 +120,3 @@ instance HasReps Object where

 instance HasReps [(ContentType, B.ByteString)] where
    reps = id
-
-- FIXME put in a separate module (maybe Web.Encodings)
-formatW3 :: UTCTime -> String
-formatW3 = formatTime defaultTimeLocale "%FT%X-08:00"
-
-getRequest :: (Monad m, Request r) => ResponseT m r
-getRequest = ResponseT $ \rr -> return (helper rr, []) where
-    helper :: Request r
-           => RawRequest
-           -> Either ErrorResult r
-    helper rr =
-        case runRequestParser parseRequest rr of
-            Left errors -> Left $ InvalidArgs errors -- FIXME better error output
-            Right r -> Right r
--- a/Web/Restful/Response/AtomFeed.hs
+++ b/Web/Restful/Response/AtomFeed.hs
@ -18,6 +18,7 @@ module Web.Restful.Response.AtomFeed
    ) where

 import Web.Restful.Response
+import Web.Restful.Utils

 import Data.Time.Clock
 import Web.Encodings
--- a/Web/Restful/Response/Sitemap.hs
+++ b/Web/Restful/Response/Sitemap.hs
@ -19,7 +19,9 @@ module Web.Restful.Response.Sitemap
    , SitemapChangeFreq (..)
    ) where

+import Web.Restful.Handler
 import Web.Restful.Response
+import Web.Restful.Utils
 import Web.Encodings
 import qualified Hack
 import Web.Restful.Request
@ -86,7 +88,7 @@ instance HasReps SitemapResponse where
        [ ("text/xml", toLazyByteString $ show res)
        ]

-sitemap :: IO [SitemapUrl] -> SitemapRequest -> ResponseIO SitemapResponse
+sitemap :: IO [SitemapUrl] -> SitemapRequest -> Handler
 sitemap urls' req = do
    urls <- liftIO urls'
-    return $ SitemapResponse req urls
+    return $ reps $ SitemapResponse req urls
--- a/Web/Restful/Utils.hs
+++ b/Web/Restful/Utils.hs
@ -9,15 +9,23 @@
 -- Portability   : portable
 --
 -- Utility functions for Restful.
+-- These are all functions which could be exported to another library.
 --
 ---------------------------------------------------------
 module Web.Restful.Utils
    ( parseHttpAccept
    , tryLookup
+    , formatW3
    ) where

 import Data.List.Split (splitOneOf)
+import Data.Maybe (fromMaybe)

+import Data.Time.Clock
+import System.Locale
+import Data.Time.Format
+
+-- | Parse the HTTP accept string to determine supported content types.
 parseHttpAccept :: String -> [String]
 parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";,"

@ -26,8 +34,10 @@ specialHttpAccept ('q':'=':_) = True
 specialHttpAccept ('*':_) = True
 specialHttpAccept _ = False

+-- | Attempt a lookup, returning a default value on failure.
 tryLookup :: Eq k => v -> k -> [(k, v)] -> v
-tryLookup v _ [] = v
-tryLookup v k ((k', v'):rest)
-    | k == k' = v'
-    | otherwise = tryLookup v k rest
+tryLookup def key = fromMaybe def . lookup key
+
+-- | Format a 'UTCTime' in W3 format; useful for setting cookies.
+formatW3 :: UTCTime -> String
+formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" -- FIXME time zone?