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)
curl :: String
-> [(String, String)]
-> IO (Either String String)
curl :: String -> [(String, String)] -> IO (Either String String)
curl url :: String
url params :: [(String, String)]
params = do
(Nothing, Just hout :: Handle
hout, Just herr :: Handle
herr, phandle :: 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 "curl"
[String
url, "-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
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
_ -> 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
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
authenticate :: String
-> String
-> IO (Either String Identifier)
authenticate :: String -> String -> IO (Either String Identifier)
authenticate apiKey :: String
apiKey token :: String
token = do
Either String String
body <- String -> [(String, String)] -> IO (Either String String)
curl
"https://rpxnow.com/api/v2/auth_info"
[ ("apiKey", String
apiKey)
, ("token", String
token)
]
case Either String String
body of
Left s :: 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
$ "Unable to connect to rpxnow: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
Right b :: 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 s :: 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
$ "Not a valid JSON response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
Ok o :: JSObject JSValue
o ->
case String -> JSObject JSValue -> Result String
forall a. JSON a => String -> JSObject JSValue -> Result a
valFromObj "stat" JSObject JSValue
o of
Error _ -> 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 "Missing 'stat' field"
Ok "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 stat :: 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
$ "Login not accepted: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
stat
parseProfile :: JSObject JSValue -> Result Identifier
parseProfile :: JSObject JSValue -> Result Identifier
parseProfile v :: JSObject JSValue
v = do
JSObject JSValue
profile <- String -> JSObject JSValue -> Result JSValue
forall a. JSON a => String -> JSObject JSValue -> Result a
valFromObj "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 "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 (\(k :: String
k, _) -> String
k String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "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 (k :: String
k, JSString v :: JSString
v) = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
k, JSString -> String
fromJSString JSString
v)
takeString _ = Maybe (String, String)
forall a. Maybe a
Nothing
getObject :: JSValue -> Result (JSObject JSValue)
getObject :: JSValue -> Result (JSObject JSValue)
getObject (JSObject o :: JSObject JSValue
o) = JSObject JSValue -> Result (JSObject JSValue)
forall (m :: * -> *) a. Monad m => a -> m a
return JSObject JSValue
o
getObject _ = String -> Result (JSObject JSValue)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Not an object"