    -- 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 a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Either String String -> IO (Either String String)
    forall a. a -> IO a
    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 a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Either String String -> IO (Either String String)
    forall a. a -> IO a
    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
    $cshowsPrec :: Int -> Identifier -> ShowS
    showsPrec :: Int -> Identifier -> ShowS
    $cshow :: Identifier -> String
    show :: Identifier -> String
    $cshowList :: [Identifier] -> ShowS
    showList :: [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 a. a -> IO a
    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 a b. Result a -> (a -> Result b) -> Result b
    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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a b. Result a -> (a -> Result b) -> Result b
    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 a. a -> Result a
    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 a. a -> Result a
    forall (m :: * -> *) a. Monad m => a -> m a
    return JSObject JSValue
    o
    getObject JSValue
    _ = String -> Result (JSObject JSValue)
    forall a. String -> Result a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Not an object"