Vastly simplified Web.Restful.Application
This commit is contained in:
Michael Snoyman
parent
c4eb5e1ee7
commit
cb963a6231
93
Data/Object/Instances.hs
Normal file
93
Data/Object/Instances.hs
Normal file
@ -0,0 +1,93 @@
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Data.Object.Instances
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- 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 "<!DOCTYPE html>\n<html><body>"
|
||||
, helper o
|
||||
, toStrictByteString "</body></html>"
|
||||
] where
|
||||
helper :: Object -> B.ByteString
|
||||
helper (Scalar s) = B.concat
|
||||
[ toStrictByteString "<p>"
|
||||
, s
|
||||
, toStrictByteString "</p>"
|
||||
]
|
||||
helper (Sequence []) = toStrictByteString "<ul></ul>"
|
||||
helper (Sequence s) = B.concat
|
||||
[ toStrictByteString "<ul><li>"
|
||||
, B.intercalate (toStrictByteString "</li><li>") $ map helper s
|
||||
, toStrictByteString "</li></ul>"
|
||||
]
|
||||
helper (Mapping m) = B.concat $
|
||||
toStrictByteString "<dl>" :
|
||||
map helper2 m ++
|
||||
[ toStrictByteString "</dl>" ]
|
||||
helper2 :: (B.ByteString, Object) -> B.ByteString
|
||||
helper2 (k, v) = B.concat $
|
||||
[ toStrictByteString "<dt>"
|
||||
, k
|
||||
, toStrictByteString "</dt><dd>"
|
||||
, helper v
|
||||
, toStrictByteString "</dd>"
|
||||
]
|
||||
@ -1,27 +0,0 @@
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Web.Restful
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- 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
|
||||
@ -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) _) = "<p class='message'>" ++ encodeHtml s ++
|
||||
"</p>"
|
||||
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 ++
|
||||
"<form method='get' action='forward/'>" ++
|
||||
"OpenID: <input type='text' name='openid'>" ++
|
||||
"<input type='submit' value='Login'>" ++
|
||||
"</form>"
|
||||
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
|
||||
}
|
||||
|
||||
@ -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 []
|
||||
|
||||
@ -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
|
||||
|
||||
216
Web/Restful/Helpers/Auth.hs
Normal file
216
Web/Restful/Helpers/Auth.hs
Normal file
@ -0,0 +1,216 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Web.Restful.Helpers.Auth
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- 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) _) = "<p class='message'>" ++ encodeHtml s ++
|
||||
"</p>"
|
||||
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 ++
|
||||
"<form method='get' action='forward/'>" ++
|
||||
"OpenID: <input type='text' name='openid'>" ++
|
||||
"<input type='submit' value='Login'>" ++
|
||||
"</form>"
|
||||
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
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user