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 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
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
authenticate :: String
-> String
-> 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"