module Network.OAuth.Consumer
(
OAuthMonadT()
, OAuthRequest(unpackRq)
, Token(..)
, Application(..)
, OAuthCallback(..)
, SigMethod(..)
, Realm(..)
, Nonce(..)
, Timestamp(..)
, runOAuth
, runOAuthM
, oauthRequest
, packRq
, signRq
, signRq2
, 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
import Control.Monad.Trans
import System.IO
import System.Entropy (getEntropy)
import System.Locale (defaultTimeLocale)
import Data.Time (getCurrentTime,formatTime)
import Data.Char (chr,ord)
import Data.List (intercalate,sort)
import Data.Word (Word8)
import qualified Data.Binary as Bi
import qualified Data.Digest.Pure.SHA as S
import qualified Codec.Binary.Base64 as B64
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as B
import qualified Codec.Crypto.RSA as R
import qualified Crypto.Types.PubKey.RSA as R
newtype OAuthRequest = OAuthRequest { unpackRq :: Request }
deriving (Show)
newtype Nonce = Nonce { unNonce :: String }
deriving (Eq)
newtype Timestamp = Timestamp { unTimestamp :: String }
deriving (Eq,Ord)
newtype Realm = Realm { unRealm :: String }
deriving (Eq)
data OAuthCallback = URL String
| OOB
deriving (Eq)
data Application = Application { consKey :: String
, consSec :: String
, callback :: OAuthCallback
}
deriving (Eq)
data Token =
TwoLegg { application :: Application
, oauthParams :: FieldList
}
| ReqToken { application :: Application
, oauthParams :: FieldList
}
| AccessToken { application :: Application
, oauthParams :: FieldList
}
deriving (Eq)
data SigMethod =
PLAINTEXT
| HMACSHA1
| RSASHA1 R.PrivateKey
data OAuthMonadT m a = OAuthMonadT (Token -> m (Either String (Token,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))
RSASHA1 k -> b64encode $ R.rsassa_pkcs1_v1_5_sign R.ha_SHA1 k (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 -> OAuthMonadT m ()
ignite = putToken . fromApplication
fromApplication :: Application -> Token
fromApplication app = TwoLegg app empty
runOAuth :: (Monad m) => (String -> m a) -> Token -> OAuthMonadT m a -> m a
runOAuth h t (OAuthMonadT f) = do { v <- f t
; case v
of Right (_,a) -> return a
Left err -> h err
}
runOAuthM :: (Monad m) => Token -> OAuthMonadT m a -> m a
runOAuthM = runOAuth fail
oauthRequest :: (HttpClient c, MonadIO m) => c -> OAuthRequest -> OAuthMonadT m Token
oauthRequest c req = do { response <- serviceRequest c req
; token <- getToken
; case (fromResponse response token)
of Right token' -> do { putToken token'
; return token'
}
Left err -> fail err
}
serviceRequest :: (HttpClient c,MonadIO m) => c -> OAuthRequest -> OAuthMonadT m Response
serviceRequest c req = do { result <- lift $ runClient c (unpackRq req)
; case (result)
of Right rsp -> return rsp
Left err -> fail $ "Failure performing the request. [reason=" ++ err ++"]"
}
signRq2 :: (MonadIO m) => SigMethod -> Maybe Realm -> Request -> OAuthMonadT m OAuthRequest
signRq2 sigm realm req = getToken >>= \t -> lift $ signRq t sigm realm req
packRq :: Request -> OAuthRequest
packRq = OAuthRequest
signRq :: (MonadIO m) => Token -> SigMethod -> Maybe Realm -> Request -> m OAuthRequest
signRq token sigm realm req0 = do { nonce <- _nonce
; timestamp <- _timestamp
; let authValue = authorization sigm realm nonce timestamp token req0
req = req0 { reqHeaders = insert ("Authorization", authValue) (reqHeaders req0) }
; return (OAuthRequest req)
}
getToken :: (Monad m) => OAuthMonadT m Token
getToken = OAuthMonadT $ \t -> return $ Right (t,t)
putToken :: (Monad m) => Token -> OAuthMonadT m ()
putToken t = OAuthMonadT $ const (return $ Right (t,()))
injectOAuthVerifier :: String -> Token -> Token
injectOAuthVerifier value (ReqToken app params) = ReqToken app (replace ("oauth_verifier", value) params)
injectOAuthVerifier _ token = token
cliAskAuthorization :: (MonadIO m) => (Token -> String) -> OAuthMonadT m ()
cliAskAuthorization getUrl = do { token <- getToken
; answer <- liftIO $ do { hSetBuffering stdout NoBuffering
; putStrLn ("open " ++ (getUrl token))
; putStr "oauth_verifier: "
; getLine
}
; putToken (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 errorMessage
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
| twoLegged token = [ "oauth_token"
, "oauth_token_secret"
, "oauth_callback_confirmed"
]
| otherwise = [ "oauth_token"
, "oauth_token_secret"
]
errorMessage
| not statusOk = "Bad status code. [response=" ++ debug ++ "]"
| not paramsOk = "Missing at least one required oauth parameter [expecting="++ show requiredKeys ++", response="++ debug ++"]"
| otherwise = error "Consumer#fromResponse: not an error!"
where debug = concat [ "status: " ++ show (status rsp)
, ", reason: " ++ reason rsp
]
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", unNonce nonce)
, ("oauth_timestamp", unTimestamp time)
, ("oauth_signature_method", showMethod m)
, ("oauth_version", "1.0")
] ++ extra
showMethod HMACSHA1 = "HMAC-SHA1"
showMethod (RSASHA1 _) = "RSA-SHA1"
showMethod PLAINTEXT = "PLAINTEXT"
oauthPrefix = case realm
of Nothing -> "OAuth "
Just v -> "OAuth realm=\"" ++ encode (unRealm 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 = liftIO $ liftM (Nonce . B64.encode . BS.unpack) (getEntropy 32)
_timestamp :: (MonadIO m) => m Timestamp
_timestamp = do { clock <- liftIO getCurrentTime
; return (Timestamp $ formatTime defaultTimeLocale "%s" clock)
}
instance (Monad m) => Monad (OAuthMonadT m) where
return a = OAuthMonadT $ \t -> return $ Right (t,a)
fail err = OAuthMonadT $ \_ -> return $ Left err
(OAuthMonadT ma) >>= f = OAuthMonadT $ \t0 -> ma t0 >>= either left right
where left = return . Left
right (t1,a) = let OAuthMonadT mb = f a
in mb t1
instance MonadTrans OAuthMonadT where
lift ma = OAuthMonadT $ \t -> do { a <- ma
; return $ Right (t,a)
}
instance (MonadIO m) => MonadIO (OAuthMonadT m) where
liftIO ma = OAuthMonadT $ \t -> do { a <- liftIO ma
; return $ Right (t,a)
}
instance (Monad m,Functor m) => Functor (OAuthMonadT m) where
fmap f (OAuthMonadT ma) = OAuthMonadT $ \t0 -> ma t0 >>= either left right
where left = return . Left
right (t1,a) = return (Right (t1, f a))
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
_ -> fail "Consumer#get: 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)
}
_ -> fail "Consumer#get: parse error"
}