-- 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 (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
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 IO String
-> (String -> IO (Either String String))
-> IO (Either String String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
forall a b. b -> Either a b
Right
        ExitCode
_           -> Handle -> IO String
hGetContents Handle
herr IO String
-> (String -> IO (Either String String))
-> IO (Either String String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> (String -> Either String String)
-> String
-> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String String
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
(Int -> Identifier -> ShowS)
-> (Identifier -> String)
-> ([Identifier] -> ShowS)
-> Show Identifier
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 -> Either String Identifier -> IO (Either String Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Identifier -> IO (Either String Identifier))
-> Either String Identifier -> IO (Either String Identifier)
forall a b. (a -> b) -> a -> b
$ String -> Either String Identifier
forall a b. a -> Either a b
Left (String -> Either String Identifier)
-> String -> Either String Identifier
forall a b. (a -> b) -> a -> b
$ String
"Unable to connect to rpxnow: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
        Right String
b ->
          case String -> Result JSValue
forall a. JSON a => String -> Result a
decode String
b Result JSValue
-> (JSValue -> Result (JSObject JSValue))
-> Result (JSObject JSValue)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSValue -> Result (JSObject JSValue)
getObject of
            Error String
s -> Either String Identifier -> IO (Either String Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Identifier -> IO (Either String Identifier))
-> Either String Identifier -> IO (Either String Identifier)
forall a b. (a -> b) -> a -> b
$ String -> Either String Identifier
forall a b. a -> Either a b
Left (String -> Either String Identifier)
-> String -> Either String Identifier
forall a b. (a -> b) -> a -> b
$ String
"Not a valid JSON response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
            Ok JSObject JSValue
o ->
              case String -> JSObject JSValue -> Result String
forall a. JSON a => String -> JSObject JSValue -> Result a
valFromObj String
"stat" JSObject JSValue
o of
                Error String
_ -> Either String Identifier -> IO (Either String Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Identifier -> IO (Either String Identifier))
-> Either String Identifier -> IO (Either String Identifier)
forall a b. (a -> b) -> a -> b
$ String -> Either String Identifier
forall a b. a -> Either a b
Left String
"Missing 'stat' field"
                Ok String
"ok" -> Either String Identifier -> IO (Either String Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Identifier -> IO (Either String Identifier))
-> Either String Identifier -> IO (Either String Identifier)
forall a b. (a -> b) -> a -> b
$ Result Identifier -> Either String Identifier
forall a. Result a -> Either String a
resultToEither (Result Identifier -> Either String Identifier)
-> Result Identifier -> Either String Identifier
forall a b. (a -> b) -> a -> b
$ JSObject JSValue -> Result Identifier
parseProfile JSObject JSValue
o
                Ok String
stat -> Either String Identifier -> IO (Either String Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Identifier -> IO (Either String Identifier))
-> Either String Identifier -> IO (Either String Identifier)
forall a b. (a -> b) -> a -> b
$ String -> Either String Identifier
forall a b. a -> Either a b
Left (String -> Either String Identifier)
-> String -> Either String Identifier
forall a b. (a -> b) -> a -> b
$ String
"Login not accepted: " String -> ShowS
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 <- String -> JSObject JSValue -> Result JSValue
forall a. JSON a => String -> JSObject JSValue -> Result a
valFromObj String
"profile" JSObject JSValue
v Result JSValue
-> (JSValue -> Result (JSObject JSValue))
-> Result (JSObject JSValue)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSValue -> Result (JSObject JSValue)
getObject
    String
ident <- String -> JSObject JSValue -> Result String
forall a. JSON a => String -> JSObject JSValue -> Result a
valFromObj String
"identifier" JSObject JSValue
profile
    let pairs :: [(String, JSValue)]
pairs = JSObject JSValue -> [(String, JSValue)]
forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
profile
        pairs' :: [(String, JSValue)]
pairs' = ((String, JSValue) -> Bool)
-> [(String, JSValue)] -> [(String, JSValue)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
k, JSValue
_) -> String
k String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"identifier") [(String, JSValue)]
pairs
        pairs'' :: [(String, String)]
pairs'' = (Maybe (String, String) -> (String, String))
-> [Maybe (String, String)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (String, String) -> (String, String)
forall a. HasCallStack => Maybe a -> a
fromJust ([Maybe (String, String)] -> [(String, String)])
-> ([(String, JSValue)] -> [Maybe (String, String)])
-> [(String, JSValue)]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (String, String) -> Bool)
-> [Maybe (String, String)] -> [Maybe (String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter Maybe (String, String) -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe (String, String)] -> [Maybe (String, String)])
-> ([(String, JSValue)] -> [Maybe (String, String)])
-> [(String, JSValue)]
-> [Maybe (String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, JSValue) -> Maybe (String, String))
-> [(String, JSValue)] -> [Maybe (String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String, JSValue) -> Maybe (String, String)
takeString ([(String, JSValue)] -> [(String, String)])
-> [(String, JSValue)] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ [(String, JSValue)]
pairs'
    Identifier -> Result Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier -> Result Identifier)
-> Identifier -> Result Identifier
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) = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
k, JSString -> String
fromJSString JSString
v)
takeString (String, JSValue)
_ = Maybe (String, String)
forall a. Maybe a
Nothing

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