module Text.AccentuateUs
( Lang
, Locale
, AUSResponse(..)
, LangsStatus(..)
, langs
, accentuate
, feedback
) where
import Control.Monad (liftM)
import Data.Maybe (fromMaybe)
import Network.HTTP (Header(Header), HeaderName(..), Request(Request)
, RequestMethod(POST), getResponseBody, simpleHTTP, catchIO)
import Network.URI (URI(URI), URIAuth(URIAuth))
import Text.JSON (JSON(..), decode, encode, JSValue(..), resultToEither,
toJSObject, valFromObj)
type Lang = String
type Locale = String
langs :: Maybe Locale -> Int -> IO (Either String AUSResponse)
langs l v = catchIO (liftM eitherDecode call) (\_ -> err)
where
call = post [PCall "langs", PLocale (fromMaybe "" l), PVersion v]
err = return . Left $ "Network error. Unale to retrieve languages."
accentuate :: Lang -> Maybe Locale -> String -> IO (Either String AUSResponse)
accentuate la lo t = catchIO (liftM eitherDecode call) (\_ -> err)
where
call = post [PCall "lift", PLang la, PLocale (mbLocale lo), PText t]
err = return . Left $ "Network error. Unable to accentuate text for"
++ " language " ++ la
feedback :: Lang -> Maybe Locale -> String -> IO (Either String AUSResponse)
feedback la lo t = catchIO (liftM eitherDecode call) (\_ -> err)
where
call = post [PCall "feedback", PLang la, PLocale (mbLocale lo), PText t]
err = return . Left $ "Network error. Unable to submit feedback."
data Param
= PCall String
| PCode Integer
| PText String
| PLang Lang
| PLocale Locale
| PVersion Int
deriving (Show)
data AUSResponse
= Langs { status :: LangsStatus
, version :: Int
, languages :: [(String, Lang)]
}
| Lift { text :: String }
| Feedback
deriving Show
data LangsStatus = OutOfDate
| UpToDate
| OverDate
deriving (Show, Eq)
instance JSON AUSResponse where
readJSON (JSObject rsp) = do
call <- valFromObj "call" rsp
code <- valFromObj "code" rsp
case call of
"charlifter.langs" -> do
code' <- mbCode (codeToStatus code)
vers <- valFromObj "version" rsp
pairs <- pairs' code'
return Langs { status = code'
, version = read vers
, languages = pairs
}
where pairs' UpToDate = return []
pairs' _ = liftM (map splitPair . lines) txt
txt = valFromObj "text" rsp
"charlifter.lift" ->
case code::Int of
200 -> liftM Lift (valFromObj "text" rsp)
400 -> fail'
_ -> failCode
"charlifter.feedback" ->
case code::Int of
100 -> return Feedback
400 -> fail'
_ -> failCode
c -> fail ("Unknown Accentuate.us call " ++ c)
where fail' = valFromObj "text" rsp >>= \e -> fail e
failCode = fail "Unknown Accentuate.us response code"
mbCode (Just c) = return c
mbCode Nothing = failCode
readJSON _ = undefined
showJSON = undefined
codeToStatus :: Int -> Maybe LangsStatus
codeToStatus c = case c of
100 -> Just OutOfDate
200 -> Just UpToDate
400 -> Just OverDate
_ -> Nothing
splitPair :: String -> (String, String)
splitPair s = removeSep $ break (== ':') s
where removeSep (a,b) = (a, tail b)
post :: [Param] -> IO String
post ps = (simpleHTTP . prepRequest $ ps) >>= \r -> getResponseBody r
prepRequest :: [Param] -> Request String
prepRequest params = Request (url lang) POST (headers body) body
where ps = toQuery params
body = encode . toJSObject $ ps
lang = fromMaybe "" ("lang" `lookup` ps)
toQuery :: [Param] -> [(String, String)]
toQuery = map toQuery' where
toQuery' p = case p of
PCall c -> ("call", "charlifter." ++ c)
PCode c -> ("code", show c)
PText t -> ("text", t)
PLang l -> ("lang", l)
PLocale l -> ("locale", l)
PVersion v -> ("version", show v)
eitherDecode :: (JSON a) => String -> Either String a
eitherDecode = resultToEither . decode
mbLocale :: Maybe String -> String
mbLocale = fromMaybe ""
headers :: String -> [Header]
headers s = [Header HdrContentType "application/json; charset=utf-8"
, Header HdrUserAgent "Accentuate.us/0.9 haskell"
, Header HdrContentLength cl
] where cl = show . length $ s
url :: Lang -> URI
url lang = URI "http:" uriAuth "/" "" ""
where uriAuth = Just (URIAuth "" host ":8080")
base = "api.accentuate.us"
host = (if lang /= "" then lang ++ "." else lang) ++ base