diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs new file mode 100644 index 00000000..6f2301ef --- /dev/null +++ b/Data/Object/Instances.hs @@ -0,0 +1,93 @@ +--------------------------------------------------------- +-- +-- Module : Data.Object.Instances +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Instances for converting various types of data into Data.Object.Object. +-- +--------------------------------------------------------- +module Data.Object.Instances + ( Json (..) + , Yaml (..) + , Html (..) + ) where + +import Data.Object +import qualified Data.ByteString as B +import Data.ByteString.Class +import Web.Encodings (encodeJson) +import qualified Text.Yaml as Y + +newtype Json = Json B.ByteString +instance FromObject Json where + fromObject = return . Json . helper where + helper :: Object -> B.ByteString + helper (Scalar s) = B.concat + [ toStrictByteString "\"" + , encodeJson $ fromStrictByteString s + , toStrictByteString "\"" + ] + helper (Sequence s) = B.concat + [ toStrictByteString "[" + , B.intercalate (toStrictByteString ",") $ map helper s + , toStrictByteString "]" + ] + helper (Mapping m) = B.concat + [ toStrictByteString "{" + , B.intercalate (toStrictByteString ",") $ map helper2 m + , toStrictByteString "}" + ] + helper2 :: (B.ByteString, Object) -> B.ByteString + helper2 (k, v) = B.concat + [ toStrictByteString "\"" + , encodeJson $ fromStrictByteString k + , toStrictByteString "\":" + , helper v + ] + +newtype Yaml = Yaml B.ByteString +instance FromObject Yaml where + fromObject = return . Yaml . Y.encode + +-- | Represents as an entire HTML 5 document by using the following: +-- +-- * A scalar is a paragraph. +-- * A sequence is an unordered list. +-- * A mapping is a definition list. +newtype Html = Html B.ByteString + +instance FromObject Html where + fromObject o = return $ Html $ B.concat + [ toStrictByteString "\n" + , helper o + , toStrictByteString "" + ] where + helper :: Object -> B.ByteString + helper (Scalar s) = B.concat + [ toStrictByteString "

" + , s + , toStrictByteString "

" + ] + helper (Sequence []) = toStrictByteString "" + helper (Sequence s) = B.concat + [ toStrictByteString "" + ] + helper (Mapping m) = B.concat $ + toStrictByteString "
" : + map helper2 m ++ + [ toStrictByteString "
" ] + helper2 :: (B.ByteString, Object) -> B.ByteString + helper2 (k, v) = B.concat $ + [ toStrictByteString "
" + , k + , toStrictByteString "
" + , helper v + , toStrictByteString "
" + ] diff --git a/Web/Restful.hs b/Web/Restful.hs deleted file mode 100644 index c2878f2c..00000000 --- a/Web/Restful.hs +++ /dev/null @@ -1,27 +0,0 @@ ---------------------------------------------------------- --- --- Module : Web.Restful --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Lightweight framework for designing RESTful APIs. --- ---------------------------------------------------------- -module Web.Restful - ( - module Data.Object - , module Web.Restful.Request - , module Web.Restful.Response - , module Web.Restful.Application - , module Web.Restful.Definitions - ) where - -import Data.Object -import Web.Restful.Request -import Web.Restful.Response -import Web.Restful.Application -import Web.Restful.Definitions diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index f03f3d43..dbe63821 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -18,24 +18,14 @@ module Web.Restful.Application ( -- * Defining an application ApplicationMonad - -- ** Routing - , addResource -- ** Settings - , setHandler - , setRpxnowApiKey - , setResourceParser , setHtmlWrapper -- ** Engage - , run - -- * FIXME - , Application (..) + , toHackApp ) where -- hideously long import list import qualified Hack -import qualified Hack.Handler.CGI -import Control.Monad.Reader -import Control.Monad.Writer import Control.Monad.State hiding (gets) import Web.Encodings import Data.Maybe (isJust) @@ -43,8 +33,7 @@ import Data.ByteString.Class import qualified Data.ByteString.Lazy as BS import Data.Function.Predicate (equals) import Data.Default -import qualified Web.Authenticate.Rpxnow as Rpxnow -import qualified Web.Authenticate.OpenId as OpenId +import Control.Applicative ( Applicative (..)) import Hack.Middleware.Gzip import Hack.Middleware.CleanPath @@ -52,19 +41,15 @@ import Hack.Middleware.Jsonp import Hack.Middleware.ClientSession import Hack.Middleware.MethodOverride -import Control.Applicative ((<$>), Applicative (..)) -import Control.Arrow (second) - import Web.Restful.Request import Web.Restful.Response -import Web.Restful.Constants import Web.Restful.Utils import Web.Restful.Handler import Web.Restful.Definitions -import Data.Object +import Web.Restful.Constants -- | Contains settings and a list of resources. -type ApplicationMonad a = StateT (ApplicationSettings a) (Writer (HandlerMap a)) +type ApplicationMonad a = State (ApplicationSettings a) instance Applicative (ApplicationMonad a) where pure = return f <*> a = do @@ -72,20 +57,16 @@ instance Applicative (ApplicationMonad a) where a' <- a return $! f' a' data ApplicationSettings rn = ApplicationSettings - { hackHandler :: Hack.Application -> IO () - , rpxnowApiKey :: Maybe String - , encryptKey :: Either FilePath Word256 - , appResourceParser :: ResourceParser rn + { encryptKey :: Either FilePath Word256 , hackMiddleware :: [Hack.Middleware] , response404 :: Hack.Env -> IO Hack.Response , htmlWrapper :: BS.ByteString -> BS.ByteString } -instance ResourceName a => Default (ApplicationSettings a) where + +instance (HasResourceParser a) => + Default (ApplicationSettings a) where def = ApplicationSettings - { hackHandler = Hack.Handler.CGI.run - , rpxnowApiKey = Nothing - , encryptKey = Left defaultKeyFile - , appResourceParser = \s -> ParsedResource (toResourceName s) [] + { encryptKey = Left defaultKeyFile , hackMiddleware = [ gzip , cleanPath @@ -105,250 +86,65 @@ default404 env = return $ -- FIXME document below here -addResource :: (Request req, Response res, ResourceName rn) - => Verb - -> rn - -> (req -> IO res) - -> ApplicationMonad rn () -addResource verb resourceName' f = do - let handler :: Handler - handler = Handler $ (fmap ResponseWrapper) . f - handlerDesc = HandlerDesc resourceName' verb handler - tell [handlerDesc] - -setResourceParser :: ResourceName rn - => ResourceParser rn - -> ApplicationMonad rn () -setResourceParser newRP = do - s <- get - put $ s { appResourceParser = newRP } - setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad a () setHtmlWrapper f = do s <- get put $ s { htmlWrapper = f } -run :: ResourceName a => ApplicationMonad a () -> IO () -run m = do - let (settings, resources') = runWriter $ execStateT m def +toHackApp :: (Eq a, HasResourceParser a, HasHandlers a b) + => ApplicationMonad a () + -> b + -> IO Hack.Application +toHackApp am model = do + let settings = execState am def key <- case encryptKey settings of Left f -> getKey f Right k -> return k - let defApp = defaultResources settings - defResources = execWriter $ execStateT defApp def - resources = resources' ++ defResources -- FIXME rename HandlerDescs - app' :: Hack.Application - app' = toHackApplication $ Application resources settings - clientsession' :: Hack.Middleware - clientsession' = clientsession [authCookieName] key - app :: Hack.Application + let handlers = getHandler model + app' = toHackApplication handlers settings + clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way... app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] - hackHandler settings app + return app -setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad a () -setHandler h = do - settings <- get - put $ settings { hackHandler = h } - -setRpxnowApiKey :: String -> ApplicationMonad a () -setRpxnowApiKey k = do - settings <- get - put $ settings { rpxnowApiKey = Just k } - -defaultResources :: ResourceName rn - => ApplicationSettings rn - -> ApplicationMonad rn () -defaultResources settings = do - addResource Get (toResourceName ["auth", "check"]) authCheck - addResource Get (toResourceName ["auth", "logout"]) authLogout - addResource Get (toResourceName ["auth", "openid"]) authOpenidForm - addResource Get (toResourceName ["auth", "openid", "forward"]) authOpenidForward - addResource Get (toResourceName ["auth", "openid", "complete"]) authOpenidComplete - case rpxnowApiKey settings of - Nothing -> return () - Just key -> do - addResource Get (toResourceName ["auth", "login", "rpxnow"]) $ - rpxnowLogin key - -data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) -instance Request OIDFormReq where - parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" -instance Show OIDFormReq where - show (OIDFormReq Nothing _) = "" - show (OIDFormReq (Just s) _) = "

" ++ encodeHtml s ++ - "

" -data OIDFormRes = OIDFormRes String (Maybe String) -instance Response OIDFormRes where - reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] - where - heads = - case dest of - Nothing -> [] - Just dest' -> - [("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")] -authOpenidForm :: OIDFormReq -> IO OIDFormRes -authOpenidForm m@(OIDFormReq _ dest) = - let html = - show m ++ - "
" ++ - "OpenID: " ++ - "" ++ - "
" - in return $! OIDFormRes html dest -data OIDFReq = OIDFReq String String -instance Request OIDFReq where - parseRequest = do - oid <- getParam "openid" - env <- parseEnv - let complete = "http://" ++ Hack.serverName env ++ ":" ++ - show (Hack.serverPort env) ++ - "/auth/openid/complete/" - return $! OIDFReq oid complete -authOpenidForward :: OIDFReq -> IO GenResponse -authOpenidForward (OIDFReq oid complete) = do - res <- OpenId.getForwardUrl oid complete :: IO (Either String String) - return $ - case res of - Left err -> RedirectResponse $ "/auth/openid/?message=" ++ - encodeUrl err - Right url -> RedirectResponse url - -data OIDComp = OIDComp [(String, String)] (Maybe String) -instance Request OIDComp where - parseRequest = do - rr <- ask - let gets = rawGetParams rr - dest <- cookieParam "DEST" - return $! OIDComp gets dest -data OIDCompRes = OIDCompResErr String - | OIDCompResGood String (Maybe String) -instance Response OIDCompRes where - reps (OIDCompResErr err) = - reps $ RedirectResponse - $ "/auth/openid/?message=" ++ - encodeUrl err - reps (OIDCompResGood ident Nothing) = - reps $ OIDCompResGood ident (Just "/") - reps (OIDCompResGood ident (Just dest)) = - [("text/plain", response 303 heads "")] where - heads = - [ (authCookieName, ident) - , resetCookie "DEST" - , ("Location", dest) - ] - -resetCookie :: String -> (String, String) -resetCookie name = - ("Set-Cookie", - name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") - -authOpenidComplete :: OIDComp -> IO OIDCompRes -authOpenidComplete (OIDComp gets' dest) = do - res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) - return $ - case res of - Left err -> OIDCompResErr err - Right (OpenId.Identifier ident) -> OIDCompResGood ident dest - --- | token dest -data RpxnowRequest = RpxnowRequest String (Maybe String) -instance Request RpxnowRequest where - parseRequest = do - token <- getParam "token" - dest <- getParam "dest" - return $! RpxnowRequest token $ chopHash `fmap` dest - -chopHash :: String -> String -chopHash ('#':rest) = rest -chopHash x = x - --- | dest identifier -data RpxnowResponse = RpxnowResponse String (Maybe String) -instance Response RpxnowResponse where - reps (RpxnowResponse dest Nothing) = - [("text/html", response 303 [("Location", dest)] "")] - reps (RpxnowResponse dest (Just ident)) = - [("text/html", response 303 - [ ("Location", dest) - , (authCookieName, ident) - ] - "")] - -rpxnowLogin :: String -- ^ api key - -> RpxnowRequest - -> IO RpxnowResponse -rpxnowLogin apiKey (RpxnowRequest token dest') = do - let dest = case dest' of - Nothing -> "/" - Just "" -> "/" - Just s -> s - ident' <- Rpxnow.authenticate apiKey token - return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') - -data AuthRequest = AuthRequest (Maybe String) -instance Request AuthRequest where - parseRequest = AuthRequest `fmap` identifier - -authCheck :: AuthRequest -> IO Object -authCheck (AuthRequest Nothing) = - return $ toObject [("status", "notloggedin")] -authCheck (AuthRequest (Just i)) = - return $ toObject - [ ("status", "loggedin") - , ("ident", i) - ] - -authLogout :: () -> IO LogoutResponse -authLogout _ = return LogoutResponse - -data LogoutResponse = LogoutResponse -instance Response LogoutResponse where - reps _ = map (second addCookie) $ reps tree where - tree = toObject [("status", "loggedout")] - addCookie (Hack.Response s h c) = - Hack.Response s (h':h) c - h' = resetCookie authCookieName - -toHackApplication :: Eq resourceName - => Application resourceName +toHackApplication :: (HasResourceParser resourceName, Eq resourceName) + => HandlerMap resourceName + -> ApplicationSettings resourceName -> Hack.Application -toHackApplication (Application hm settings) env = do +toHackApplication hm settings env = do let (Right resource) = splitPath $ Hack.pathInfo env - (ParsedResource rn urlParams') = (appResourceParser settings) resource - verb :: Verb - verb = toVerb $ Hack.requestMethod env - rr :: RawRequest - rr = envToRawRequest urlParams' env - matchingHandler (HandlerDesc resourceName' verb' _) = - rn == resourceName' && - verb == verb' - case filter matchingHandler hm of - [HandlerDesc _ _ handler] -> do - let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env - ctypes' = parseHttpAccept rawHttpAccept - body <- runHandler handler rr - let reps' = reps body - ctypes = filter (\c -> isJust $ lookup c reps') ctypes' - let handlerPair = - case ctypes of - [] -> Just $ head reps' - (c:_) -> - case filter (fst `equals` c) reps' of - [pair] -> Just pair - [] -> Nothing - _ -> error "Overlapping reps" - case handlerPair of - Nothing -> response404 settings $ env - Just (ctype, Hack.Response status headers content) -> do - let wrapper = - case ctype of - "text/html" -> htmlWrapper settings - _ -> id - return $ Hack.Response status - (("Content-Type", ctype) : headers) - $ toLazyByteString $ wrapper content - [] -> response404 settings $ env - _ -> fail $ "Overlapping handlers for: " ++ show env + case resourceParser resource of + Nothing -> response404 settings $ env + (Just (ParsedResource rn urlParams')) -> do + let verb :: Verb + verb = toVerb $ Hack.requestMethod env + rr :: RawRequest + rr = envToRawRequest urlParams' env + case hm rn verb of + (Just handler) -> do + let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env + ctypes' = parseHttpAccept rawHttpAccept + body <- runHandler handler rr + let reps' = reps body + ctypes = filter (\c -> isJust $ lookup c reps') ctypes' + let handlerPair = + case ctypes of + [] -> Just $ head reps' + (c:_) -> + case filter (fst `equals` c) reps' of + [pair] -> Just pair + [] -> Nothing + _ -> error "Overlapping reps" + case handlerPair of + Nothing -> response404 settings $ env + Just (ctype, Hack.Response status headers content) -> do + let wrapper = + case ctype of + "text/html" -> htmlWrapper settings + _ -> id + return $ Hack.Response status + (("Content-Type", ctype) : headers) + $ toLazyByteString $ wrapper content + Nothing -> response404 settings $ env envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest urlParams' env = @@ -361,8 +157,3 @@ envToRawRequest urlParams' env = rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] in RawRequest rawPieces urlParams' gets' posts cookies' files env - -data Application a = Application - { handlerMap :: HandlerMap a - , applicationSettings :: ApplicationSettings a - } diff --git a/Web/Restful/Definitions.hs b/Web/Restful/Definitions.hs index f96ca895..12a6aab1 100644 --- a/Web/Restful/Definitions.hs +++ b/Web/Restful/Definitions.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful.Definitions @@ -18,7 +19,7 @@ module Web.Restful.Definitions , Resource , ParsedResource (..) , ResourceParser - , ResourceName (..) + , HasResourceParser (..) ) where import qualified Hack @@ -34,14 +35,14 @@ toVerb _ = Get type Resource = [String] -class Eq a => ResourceName a where - toResourceName :: [String] -> a -instance ResourceName [String] where - toResourceName = id - data ParsedResource a = ParsedResource { resourceName :: a , urlParameters :: [(String, String)] } -type ResourceParser a = Resource -> ParsedResource a +type ResourceParser a = Resource -> Maybe (ParsedResource a) + +class HasResourceParser a where + resourceParser :: ResourceParser a + simpleParse :: a -> Maybe (ParsedResource a) + simpleParse x = Just $ ParsedResource x [] diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 100440ad..980ff848 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} --------------------------------------------------------- -- -- Module : Web.Restful.Handler @@ -16,7 +18,8 @@ module Web.Restful.Handler ( Handler (..) , runHandler , HandlerMap - , HandlerDesc (..) + , HasHandlers (..) + , liftHandler ) where import Web.Restful.Definitions @@ -32,5 +35,12 @@ runHandler (Handler f) rreq = do Left errors -> fail $ unlines errors -- FIXME Right req -> f req -data HandlerDesc a = HandlerDesc a Verb Handler -type HandlerMap a = [HandlerDesc a] +type HandlerMap a = a -> Verb -> Maybe Handler + +class HasHandlers a b | a -> b where + getHandler :: b -> a -> Verb -> Maybe Handler + +liftHandler :: (Request req, Response res) + => (req -> IO res) + -> Maybe Handler +liftHandler f = Just . Handler $ fmap ResponseWrapper . f diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs new file mode 100644 index 00000000..44cd26e8 --- /dev/null +++ b/Web/Restful/Helpers/Auth.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Helpers.Auth +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Authentication through the authentication package. +-- +--------------------------------------------------------- +module Web.Restful.Helpers.Auth + ( AuthResource + , FromAuthResource (..) + , authResourceParser + ) where + +import qualified Hack +import Web.Encodings +import qualified Web.Authenticate.Rpxnow as Rpxnow +import qualified Web.Authenticate.OpenId as OpenId + +import Web.Restful +import Web.Restful.Constants + +import Control.Applicative ((<$>), Applicative (..)) +import Control.Arrow (second) +import Control.Monad.Reader + +import Data.Object + +data AuthResource = + AuthCheck + | AuthLogout + | AuthOpenid + | AuthOpenidForward + | AuthOpenidComplete + | AuthLoginRpxnow + deriving Eq +class FromAuthResource a where + fromAuthResource :: AuthResource -> a + +authResourceParser :: FromAuthResource far + => Resource + -> Maybe (ParsedResource far) +authResourceParser ["check"] = + authResourceParser' AuthCheck +authResourceParser ["logout"] = + authResourceParser' AuthLogout +authResourceParser ["openid"] = + authResourceParser' AuthOpenid +authResourceParser ["openid", "forward"] = + authResourceParser' AuthOpenidForward +authResourceParser ["openid", "complete"] = + authResourceParser' AuthOpenidComplete +authResourceParser ["login", "rpxnow"] = + authResourceParser' AuthLoginRpxnow +authResourceParser _ = Nothing + +authResourceParser' :: FromAuthResource far + => AuthResource + -> Maybe (ParsedResource far) +authResourceParser' x = Just $ ParsedResource (fromAuthResource x) [] + +type RpxnowApiKey = String -- FIXME newtype +instance HasHandlers AuthResource (Maybe RpxnowApiKey) where + getHandler _ AuthCheck Get = liftHandler authCheck + getHandler _ AuthLogout Get = liftHandler authLogout + getHandler _ AuthOpenid Get = liftHandler authOpenidForm + getHandler _ AuthOpenidForward Get = liftHandler authOpenidForward + getHandler _ AuthOpenidComplete Get = liftHandler authOpenidComplete + getHandler (Just key) AuthLoginRpxnow Get = liftHandler $ rpxnowLogin key + getHandler _ _ _ = Nothing + +data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) +instance Request OIDFormReq where + parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" +instance Show OIDFormReq where + show (OIDFormReq Nothing _) = "" + show (OIDFormReq (Just s) _) = "

" ++ encodeHtml s ++ + "

" +data OIDFormRes = OIDFormRes String (Maybe String) +instance Response OIDFormRes where + reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] + where + heads = + case dest of + Nothing -> [] + Just dest' -> + [("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")] +authOpenidForm :: OIDFormReq -> IO OIDFormRes +authOpenidForm m@(OIDFormReq _ dest) = + let html = + show m ++ + "
" ++ + "OpenID: " ++ + "" ++ + "
" + in return $! OIDFormRes html dest +data OIDFReq = OIDFReq String String +instance Request OIDFReq where + parseRequest = do + oid <- getParam "openid" + env <- parseEnv + let complete = "http://" ++ Hack.serverName env ++ ":" ++ + show (Hack.serverPort env) ++ + "/auth/openid/complete/" + return $! OIDFReq oid complete +authOpenidForward :: OIDFReq -> IO GenResponse +authOpenidForward (OIDFReq oid complete) = do + res <- OpenId.getForwardUrl oid complete :: IO (Either String String) + return $ + case res of + Left err -> RedirectResponse $ "/auth/openid/?message=" ++ + encodeUrl err + Right url -> RedirectResponse url + +data OIDComp = OIDComp [(String, String)] (Maybe String) +instance Request OIDComp where + parseRequest = do + rr <- ask + let gets = rawGetParams rr + dest <- cookieParam "DEST" + return $! OIDComp gets dest +data OIDCompRes = OIDCompResErr String + | OIDCompResGood String (Maybe String) +instance Response OIDCompRes where + reps (OIDCompResErr err) = + reps $ RedirectResponse + $ "/auth/openid/?message=" ++ + encodeUrl err + reps (OIDCompResGood ident Nothing) = + reps $ OIDCompResGood ident (Just "/") + reps (OIDCompResGood ident (Just dest)) = + [("text/plain", response 303 heads "")] where + heads = + [ (authCookieName, ident) + , resetCookie "DEST" + , ("Location", dest) + ] + +resetCookie :: String -> (String, String) +resetCookie name = + ("Set-Cookie", + name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") + +authOpenidComplete :: OIDComp -> IO OIDCompRes +authOpenidComplete (OIDComp gets' dest) = do + res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) + return $ + case res of + Left err -> OIDCompResErr err + Right (OpenId.Identifier ident) -> OIDCompResGood ident dest + +-- | token dest +data RpxnowRequest = RpxnowRequest String (Maybe String) +instance Request RpxnowRequest where + parseRequest = do + token <- getParam "token" + dest <- getParam "dest" + return $! RpxnowRequest token $ chopHash `fmap` dest + +chopHash :: String -> String +chopHash ('#':rest) = rest +chopHash x = x + +-- | dest identifier +data RpxnowResponse = RpxnowResponse String (Maybe String) +instance Response RpxnowResponse where + reps (RpxnowResponse dest Nothing) = + [("text/html", response 303 [("Location", dest)] "")] + reps (RpxnowResponse dest (Just ident)) = + [("text/html", response 303 + [ ("Location", dest) + , (authCookieName, ident) + ] + "")] + +rpxnowLogin :: String -- ^ api key + -> RpxnowRequest + -> IO RpxnowResponse +rpxnowLogin apiKey (RpxnowRequest token dest') = do + let dest = case dest' of + Nothing -> "/" + Just "" -> "/" + Just s -> s + ident' <- Rpxnow.authenticate apiKey token + return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') + +data AuthRequest = AuthRequest (Maybe String) +instance Request AuthRequest where + parseRequest = AuthRequest `fmap` identifier + +authCheck :: AuthRequest -> IO Object +authCheck (AuthRequest Nothing) = + return $ toObject [("status", "notloggedin")] +authCheck (AuthRequest (Just i)) = + return $ toObject + [ ("status", "loggedin") + , ("ident", i) + ] + +authLogout :: () -> IO LogoutResponse +authLogout _ = return LogoutResponse + +data LogoutResponse = LogoutResponse +instance Response LogoutResponse where + reps _ = map (second addCookie) $ reps tree where + tree = toObject [("status", "loggedout")] + addCookie (Hack.Response s h c) = + Hack.Response s (h':h) c + h' = resetCookie authCookieName diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 8fd46e7c..a26027bd 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -47,6 +47,7 @@ import System.Locale import Web.Restful.Request -- FIXME ultimately remove import Data.Object import Data.List (intercalate) +import Data.Object.Instances type ContentType = String diff --git a/restful.cabal b/restful.cabal index 7a10957a..661ffd09 100644 --- a/restful.cabal +++ b/restful.cabal @@ -29,7 +29,8 @@ library bytestring-class, web-encodings, mtl >= 1.1.0.2, - data-object + data-object, + yaml >= 0.0.1 exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, @@ -37,5 +38,8 @@ library Web.Restful.Utils, Web.Restful.Definitions, Web.Restful.Handler, - Web.Restful.Application + Web.Restful.Application, + Data.Object.Instances, + Hack.Middleware.MethodOverride, + Web.Restful.Helpers.Auth ghc-options: -Wall