module Network.Haskheap
( Success(..)
, getPaste
, createPaste
, deletePaste
, forkPaste
, editPaste
, getHighlightedPaste
)
where
import Control.Applicative ((<*>), (<$>))
import Control.Monad (liftM)
import Data.Time.Format (parseTime)
import Data.Time.Clock (UTCTime)
import System.Locale (defaultTimeLocale)
import Network.URI (URI, parseURI)
import Data.Aeson ((.:), (.:?), (.!=), decode, FromJSON(..), Value(..))
import Network.HTTP.Conduit (parseUrl, urlEncodedBody, Response(..), Request(..), withManager, httpLbs)
import Network.HTTP.Types (renderSimpleQuery, SimpleQuery, Method, methodGet, methodPost, methodDelete)
import Network (withSocketsDo)
import Control.Arrow ((***))
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.ByteString.Char8 as SB
parseRHTime :: String -> Maybe UTCTime
parseRHTime = parseTime defaultTimeLocale "%FT%X%QZ"
type PasteID = String
type Language = String
type Contents = String
type Query = [(String, String)]
type Auth = (String, String)
packQuery :: Query -> SimpleQuery
packQuery = map $ SB.pack *** SB.pack
composeAuth :: Auth -> Query
composeAuth (user, token) = [("username", user), ("token", token)]
data Success = Paste { getLines :: Integer
, getDate :: Maybe UTCTime
, getID :: PasteID
, getLanguage :: Language
, getPrivate :: Bool
, getURL :: Maybe URI
, getUser :: Maybe String
, getBody :: Contents
}
| Line String
| Empty
deriving (Show)
data Error = Error String deriving (Show)
instance FromJSON Error where
parseJSON (Object v) = Error <$> (v .: "error")
instance FromJSON Success where
parseJSON (Object v) =
Paste <$>
(v .: "lines") <*>
liftM parseRHTime (v .: "date") <*>
(v .: "paste-id") <*>
(v .: "language") <*>
(v .: "private") <*>
liftM parseURI (v .: "url") <*>
(v .:? "user") <*>
(v .: "contents")
refheap :: String
refheap = "https://www.refheap.com/api"
refheapReq :: Method
-> String
-> Maybe Query
-> Maybe Query
-> IO B.ByteString
refheapReq method path query body = do
let queryStr = renderSimpleQuery True . packQuery <$> query
url = refheap ++ path
req <- parseUrl $ case queryStr of
Just s -> url ++ SB.unpack s
Nothing -> url
withSocketsDo $ do
let req' = req { method = method, checkStatus = \_ _ -> Nothing }
req'' = case body of
Just b -> urlEncodedBody (packQuery b) req'
Nothing -> req'
responseBody <$> withManager (httpLbs req'')
toList :: Maybe Value -> Maybe [(T.Text, Value)]
toList (Just (Object hm)) = Just $ HM.toList hm
toList Nothing = Nothing
decodePaste :: B.ByteString -> Either Error Success
decodePaste s =
case decode s of
(Just x) -> Right x
Nothing -> case decode s of
(Just x) -> Left x
Nothing -> case toList (decode s :: Maybe Value) of
Just [("content", String x)] -> Right $ Line $ T.unpack x
_ -> Right Empty
getPaste :: PasteID -> IO (Either Error Success)
getPaste id =
liftM decodePaste $ refheapReq methodGet ("/paste/" ++ id) Nothing Nothing
createPaste :: Contents -> Bool -> Language -> Maybe Auth -> IO (Either Error Success)
createPaste body private language auth =
liftM decodePaste $ refheapReq methodPost "/paste" (composeAuth <$> auth) form
where form = Just [("contents", body)
,("private", show private)
,("language", language)]
deletePaste :: PasteID -> Auth -> IO (Either Error Success)
deletePaste id auth =
liftM decodePaste $
refheapReq methodDelete ("/paste/" ++ id) (Just $ composeAuth auth) Nothing
forkPaste :: PasteID -> Auth -> IO (Either Error Success)
forkPaste id auth =
liftM decodePaste $
refheapReq methodPost ("/paste/" ++ id ++ "/fork") (Just $ composeAuth auth) Nothing
editPaste :: PasteID -> Contents -> Bool -> Language -> Auth -> IO (Either Error Success)
editPaste id body private language auth =
liftM decodePaste $ refheapReq methodPost ("/paste/" ++ id) (Just $ composeAuth auth) form
where form = Just [("contents", body)
,("private", show private)
,("language", language)]
getHighlightedPaste :: PasteID -> IO (Either Error Success)
getHighlightedPaste id =
liftM decodePaste $ refheapReq methodGet ("/paste/" ++ id ++ "/highlight") Nothing Nothing