module Network.OAuth.Consumer (
Token(application,oauthParams)
,Application(..)
,OAuthCallback(..)
,SigMethod(..)
,Realm
,Nonce
,Timestamp
,OAuthMonad
,runOAuth
,oauthRequest
,serviceRequest
,cliAskAuthorization
,ignite
,getToken
,putToken
,twoLegged
,threeLegged
,signature
,injectOAuthVerifier
,fromApplication
,fromResponse
,authorization
) where
import Network.OAuth.Http.HttpClient
import Network.OAuth.Http.Request
import Network.OAuth.Http.Response
import Network.OAuth.Http.PercentEncoding
import Control.Monad.State
import System.Random (randomRIO)
import Data.Time (getCurrentTime,formatTime)
import System.Locale (defaultTimeLocale)
import Data.Char (chr,ord)
import Data.List (intercalate,sort)
import System.IO
import qualified Data.Binary as Bi
import Data.Word (Word8)
import qualified Data.Digest.Pure.SHA as S
import qualified Codec.Binary.Base64 as B64
import qualified Data.ByteString.Lazy as B
type Nonce = String
type Timestamp = String
type Realm = String
data OAuthCallback = URL String
| OOB
deriving (Eq)
data Application = Application { consKey :: String
, consSec :: String
, callback :: OAuthCallback
}
deriving (Show,Eq)
data Token =
TwoLegg {application :: Application
,oauthParams :: FieldList
}
| ReqToken {application :: Application
,oauthParams :: FieldList
}
| AccessToken {application :: Application
,oauthParams :: FieldList
}
deriving (Eq)
data SigMethod =
PLAINTEXT
| HMACSHA1
type OAuthMonad m a = StateT Token m a
signature :: SigMethod -> Token -> Request -> String
signature m token req = case m
of PLAINTEXT -> key
HMACSHA1 -> b64encode $ S.bytestringDigest (S.hmacSha1 (bsencode key) (bsencode text))
where bsencode = B.pack . map (fromIntegral.ord)
b64encode = B64.encode . B.unpack
key = encode (consSec (application token))
++"&"++
encode (findWithDefault ("oauth_token_secret","") (oauthParams token))
text = intercalate "&" $ map encode [show (method req)
,showURL (req {qString = empty})
,intercalate "&" . map (\(k,v) -> k++"="++v)
. sort
. map (\(k,v) -> (encode k,encode v))
. toList
$ params
]
params = if (ifindWithDefault ("content-type","") (reqHeaders req) == "application/x-www-form-urlencoded")
then (qString req) `unionAll` (parseQString . map (chr.fromIntegral)
. B.unpack
. reqPayload $ req)
else qString req
twoLegged :: Token -> Bool
twoLegged (TwoLegg _ _) = True
twoLegged _ = False
threeLegged :: Token -> Bool
threeLegged (AccessToken _ _) = True
threeLegged _ = False
ignite :: (MonadIO m) => Application -> OAuthMonad m ()
ignite = put . fromApplication
fromApplication :: Application -> Token
fromApplication app = TwoLegg app empty
runOAuth :: (MonadIO m,HttpClient m) => OAuthMonad m a -> m a
runOAuth = flip evalStateT (TwoLegg (Application "" "" OOB) empty)
oauthRequest :: (MonadIO m,HttpClient m) => SigMethod -> Maybe Realm -> Request -> OAuthMonad m (Either String Token)
oauthRequest sigm realm req = do response <- serviceRequest sigm realm req
token <- get
case (fromResponse response token)
of (Right token') -> do put token'
return (Right token')
(Left err) -> return (Left err)
serviceRequest :: (MonadIO m,HttpClient m) => SigMethod -> Maybe Realm -> Request -> OAuthMonad m Response
serviceRequest sigm realm req = do nonce <- _nonce
timestamp <- _timestamp
token <- get
let authValue = authorization sigm realm nonce timestamp token req
lift (request (req {reqHeaders = insert ("Authorization",authValue) (reqHeaders req)}))
getToken :: (Monad m) => OAuthMonad m Token
getToken = get
putToken :: (Monad m) => Token -> OAuthMonad m ()
putToken = put
injectOAuthVerifier :: String -> Token -> Token
injectOAuthVerifier value (ReqToken app params) = ReqToken app (replace ("oauth_verifier",value) params)
injectOAuthVerifier _ token = token
cliAskAuthorization :: (MonadIO m) => (Token -> String) -> OAuthMonad m ()
cliAskAuthorization getUrl = do token <- get
answer <- liftIO $ do hSetBuffering stdout NoBuffering
putStrLn ("open " ++ (getUrl token))
putStr "oauth_verifier: "
getLine
put (injectOAuthVerifier answer token)
fromResponse :: Response -> Token -> Either String Token
fromResponse rsp token | validRsp = case (token)
of (TwoLegg app params) -> Right $ ReqToken app (payload `union` params)
(ReqToken app params) -> Right $ AccessToken app (payload `union` params)
(AccessToken app params) -> Right $ AccessToken app (payload `union` params)
| otherwise = Left (statusLine rsp)
where payload = parseQString . map (chr.fromIntegral) . B.unpack . rspPayload $ rsp
validRsp = statusOk && paramsOk
statusOk = status rsp `elem` [200..299]
paramsOk = not $ null (zipWithM ($) (map (find . (==)) requiredKeys) (repeat payload))
requiredKeys = case token
of (TwoLegg _ _) -> ["oauth_token"
,"oauth_token_secret"
,"oauth_callback_confirmed"
]
_ -> ["oauth_token"
,"oauth_token_secret"
]
authorization :: SigMethod -> Maybe Realm -> Nonce -> Timestamp -> Token -> Request -> String
authorization m realm nonce time token req = oauthPrefix ++ enquote (("oauth_signature",oauthSignature):oauthFields)
where oauthFields = [("oauth_consumer_key",consKey.application $ token)
,("oauth_nonce",nonce)
,("oauth_timestamp",time)
,("oauth_signature_method",show m)
,("oauth_version","1.0")
] ++ extra
oauthPrefix = case realm
of Nothing -> "OAuth "
Just v -> "OAuth realm=\""++encode v++"\","
extra = case token
of (TwoLegg app _) -> [("oauth_callback",show.callback $ app)]
(ReqToken _ params) -> filter (not.null.snd) [("oauth_verifier",findWithDefault ("oauth_verifier","") params)
,("oauth_token",findWithDefault ("oauth_token","") params)]
(AccessToken _ params) -> filter (not.null.snd) [("oauth_token",findWithDefault ("oauth_token","") params)
,("oauth_session_handle",findWithDefault ("oauth_session_handle","") params)
]
oauthSignature = signature m token (req {qString = (qString req) `union` (fromList oauthFields)})
enquote = intercalate "," . map (\(k,v) -> encode k ++"=\""++ encode v ++"\"")
_nonce :: (MonadIO m) => m Nonce
_nonce = do rand <- liftIO (randomRIO (0,maxBound::Int))
return (show rand)
_timestamp :: (MonadIO m) => m Timestamp
_timestamp = do clock <- liftIO getCurrentTime
return (formatTime defaultTimeLocale "%s" clock)
instance Show SigMethod where
showsPrec _ PLAINTEXT = showString "PLAINTEXT"
showsPrec _ HMACSHA1 = showString "HMAC-SHA1"
instance Show OAuthCallback where
showsPrec _ OOB = showString "oob"
showsPrec _ (URL u) = showString u
instance Bi.Binary OAuthCallback where
put OOB = Bi.put (0 :: Word8)
put (URL url) = do Bi.put (1 :: Word8)
Bi.put url
get = do t <- Bi.get :: Bi.Get Word8
case t
of 0 -> return OOB
1 -> fmap URL Bi.get
_ -> error "Consumer: parse error"
instance Bi.Binary Application where
put app = do Bi.put (consKey app)
Bi.put (consSec app)
Bi.put (callback app)
get = do ckey <- Bi.get
csec <- Bi.get
callback_ <- Bi.get
return (Application ckey csec callback_)
instance Bi.Binary Token where
put (TwoLegg app params) = do Bi.put (0 :: Word8)
Bi.put app
Bi.put params
put (ReqToken app params) = do Bi.put (1 :: Word8)
Bi.put app
Bi.put params
put (AccessToken app params) = do Bi.put (2 :: Word8)
Bi.put app
Bi.put params
get = do t <- Bi.get :: Bi.Get Word8
case t
of 0 -> do app <- Bi.get
params <- Bi.get
return (TwoLegg app params)
1 -> do app <- Bi.get
params <- Bi.get
return (ReqToken app params)
2 -> do app <- Bi.get
params <- Bi.get
return (AccessToken app params)
_ -> error "Consumer: parse error"