-- Modified from Michael Snoyman's BSD3 authenticate-0.0.1
-- and http-wget-0.0.1.
-- Facilitates authentication with "http://rpxnow.com/".

module Network.Gitit.Rpxnow
    ( Identifier (..)
    , authenticate
    ) where

import Text.JSON
import Data.Maybe (isJust, fromJust)
import System.Process
import System.Exit
import System.IO
import Network.HTTP (urlEncodeVars)

-- | Make a post request with parameters to the URL and return a response.
curl :: String             -- ^ URL
     -> [(String, String)] -- ^ Post parameters
     -> IO (Either String String) -- ^ Response body
curl :: String -> [(String, String)] -> IO (Either String String)
curl String
url [(String, String)]
params = do
    (Maybe Handle
Nothing, Just Handle
hout, Just Handle
herr, ProcessHandle
phandle) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess forall a b. (a -> b) -> a -> b
$ (String -> [String] -> CreateProcess
proc String
"curl"
        [String
url, String
"-d", [(String, String)] -> String
urlEncodeVars [(String, String)]
params]
        ) { std_out :: StdStream
std_out = StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe }
    ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
phandle
    case ExitCode
exitCode of
        ExitCode
ExitSuccess -> Handle -> IO String
hGetContents Handle
hout forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
        ExitCode
_           -> Handle -> IO String
hGetContents Handle
herr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left



-- | Information received from Rpxnow after a valid login.
data Identifier = Identifier
    { Identifier -> String
userIdentifier  :: String
    , Identifier -> [(String, String)]
userData        :: [(String, String)]
    }
    deriving Int -> Identifier -> ShowS
[Identifier] -> ShowS
Identifier -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Identifier] -> ShowS
$cshowList :: [Identifier] -> ShowS
show :: Identifier -> String
$cshow :: Identifier -> String
showsPrec :: Int -> Identifier -> ShowS
$cshowsPrec :: Int -> Identifier -> ShowS
Show

-- | Attempt to log a user in.
authenticate :: String -- ^ API key given by RPXNOW.
             -> String -- ^ Token passed by client.
             -> IO (Either String Identifier)
authenticate :: String -> String -> IO (Either String Identifier)
authenticate String
apiKey String
token = do
    Either String String
body <- String -> [(String, String)] -> IO (Either String String)
curl
                String
"https://rpxnow.com/api/v2/auth_info"
                [ (String
"apiKey", String
apiKey)
                , (String
"token", String
token)
                ]
    case Either String String
body of
        Left String
s -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Unable to connect to rpxnow: " forall a. [a] -> [a] -> [a]
++ String
s
        Right String
b ->
          case forall a. JSON a => String -> Result a
decode String
b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSValue -> Result (JSObject JSValue)
getObject of
            Error String
s -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Not a valid JSON response: " forall a. [a] -> [a] -> [a]
++ String
s
            Ok JSObject JSValue
o ->
              case forall a. JSON a => String -> JSObject JSValue -> Result a
valFromObj String
"stat" JSObject JSValue
o of
                Error String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"Missing 'stat' field"
                Ok String
"ok" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Result a -> Either String a
resultToEither forall a b. (a -> b) -> a -> b
$ JSObject JSValue -> Result Identifier
parseProfile JSObject JSValue
o
                Ok String
stat -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Login not accepted: " forall a. [a] -> [a] -> [a]
++ String
stat

parseProfile :: JSObject JSValue -> Result Identifier
parseProfile :: JSObject JSValue -> Result Identifier
parseProfile JSObject JSValue
v = do
    JSObject JSValue
profile <- forall a. JSON a => String -> JSObject JSValue -> Result a
valFromObj String
"profile" JSObject JSValue
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSValue -> Result (JSObject JSValue)
getObject
    String
ident <- forall a. JSON a => String -> JSObject JSValue -> Result a
valFromObj String
"identifier" JSObject JSValue
profile
    let pairs :: [(String, JSValue)]
pairs = forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
profile
        pairs' :: [(String, JSValue)]
pairs' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
k, JSValue
_) -> String
k forall a. Eq a => a -> a -> Bool
/= String
"identifier") [(String, JSValue)]
pairs
        pairs'' :: [(String, String)]
pairs'' = forall a b. (a -> b) -> [a] -> [b]
map forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String, JSValue) -> Maybe (String, String)
takeString forall a b. (a -> b) -> a -> b
$ [(String, JSValue)]
pairs'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Identifier
Identifier String
ident [(String, String)]
pairs''

takeString :: (String, JSValue) -> Maybe (String, String)
takeString :: (String, JSValue) -> Maybe (String, String)
takeString (String
k, JSString JSString
v) = forall a. a -> Maybe a
Just (String
k, JSString -> String
fromJSString JSString
v)
takeString (String, JSValue)
_ = forall a. Maybe a
Nothing

getObject :: JSValue -> Result (JSObject JSValue)
getObject :: JSValue -> Result (JSObject JSValue)
getObject (JSObject JSObject JSValue
o) = forall (m :: * -> *) a. Monad m => a -> m a
return JSObject JSValue
o
getObject JSValue
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not an object"