diff --git a/README.mkd b/README.mkd --- a/README.mkd +++ b/README.mkd @@ -7,7 +7,15 @@ This project was created by [Spearhead Development](http://spearheaddev.com/) to implement the [Accentuate.us](http://accentuate.us/) API. -Calls +Installation +============ + +For the most stable releases, it is best to use [Hackage](http://hackage.haskell.org/package/accentuateus). +Packages can be installed via [Cabal](http://www.haskell.org/cabal/): + + cabal install accentuateus + +Usage ===== There are three primary calls to access Accentuate.us: diff --git a/Text/AccentuateUs.hs b/Text/AccentuateUs.hs deleted file mode 100644 --- a/Text/AccentuateUs.hs +++ /dev/null @@ -1,148 +0,0 @@ -module Text.AccentuateUs - ( AUSResponse(..) - , LangsStatus(..) - , langs - , accentuate - , feedback - ) where - -import Control.Monad (liftM) -import Data.Maybe (fromJust) -import Network.HTTP (Header(Header), HeaderName(..), Request(Request) - , RequestMethod(POST), getResponseBody, simpleHTTP) -import Network.URI (URI(URI), URIAuth(URIAuth)) -import Text.JSON (JSON(..), decode, encode, JSValue(..), resultToEither, - toJSObject, valFromObj) - -type Lang = String -type Locale = String - --- | Get langs and their localized names -langs :: Maybe Locale -> Int -> IO (Either String AUSResponse) -langs l v = liftM eitherDecode $ - post [PCall "langs", PLocale (mbLocale l), PVersion v] - --- | For a given language, and optionally a locale, accentuates text -accentuate :: Lang -> Maybe Locale -> String -> IO (Either String AUSResponse) -accentuate la lo t = liftM eitherDecode $ - post [PCall "lift", PLang la, PLocale (mbLocale lo), PText t] - --- | Submits corrected text as feedback to Accentuate.us -feedback :: Lang -> Maybe Locale -> String -> IO (Either String AUSResponse) -feedback la lo t = liftM eitherDecode $ - post [PCall "feedback", PLang la, PLocale (mbLocale lo), PText t] - --- | Encapsulates various properties of an Accentuate.us API call -data Param - = PCall String - | PCode Integer - | PText String - | PLang Lang - | PLocale Locale - | PVersion Int - deriving (Show) - --- | Represents responses for the three Accentuate.us calls -data AUSResponse - = Langs { status :: LangsStatus - , version :: Int - , languages :: [(String, Lang)] -- ^ [(ISO-639, Localized Language)] - } - | Lift { text :: String } - | Feedback - deriving Show - --- | Represents languages response status -data LangsStatus = OutOfDate -- ^ Given version number < server's - | UpToDate -- ^ Given version number == server's - | OverDate -- ^ Given version number > server's - deriving (Show, Eq) - -instance JSON AUSResponse where - readJSON (JSObject rsp) = do - call <- valFromObj "call" rsp - code <- valFromObj "code" rsp - case call of - "charlifter.langs" -> let code' = mbCodeToStatus code in do - 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' - _ -> fail "Unknown Accentuate.us response code." - "charlifter.feedback" -> - case code::Int of - 100 -> return Feedback - 400 -> fail' - _ -> fail "Unknown Accentuate.us response code." - _ -> fail "Unknown Accentuate.us call." - where fail' = (valFromObj "text" rsp) >>= \e -> fail e - mbCodeToStatus = fromJust . codeToStatus - readJSON _ = undefined - showJSON = undefined - --- | Converts integer response code into data type LangsStatus -codeToStatus :: Int -> Maybe LangsStatus -codeToStatus c = case c of - 100 -> Just OutOfDate - 200 -> Just UpToDate - 400 -> Just OverDate - _ -> Nothing - --- | Splits a string pair (separated by :) into a tuple, removing separator -splitPair :: String -> (String, String) -splitPair s = removeSep $ break (== ':') s - where removeSep (a,b) = (a, tail b) - --- | Sends response to server -post :: [Param] -> IO String -post ps = (simpleHTTP . prepRequest $ ps) >>= \r -> getResponseBody r - --- | Create request -prepRequest :: [Param] -> Request String -prepRequest params = Request (url lang) POST (headers body) body - where ps = toQuery params - body = encode . toJSObject $ ps - lang = maybe "" id $ "lang" `lookup` ps - --- | Map parameters to call-appropriate tuples -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) - --- | Produces locale from Maybe -mbLocale :: Maybe Locale -> Locale -mbLocale (Just l) = l -mbLocale Nothing = "" - --- | Common response parsing -eitherDecode :: (JSON a) => String -> Either String a -eitherDecode = resultToEither . decode - --- | Generate appropriate headers -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 - --- | Generate language-specific URL -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 diff --git a/accentuateus.cabal b/accentuateus.cabal --- a/accentuateus.cabal +++ b/accentuateus.cabal @@ -1,5 +1,6 @@ Name: accentuateus -Version: 0.9 +Version: 0.9.1 +Homepage: http://accentuate.us/ Description: A Haskell implementation of the Accentuate.us API. Synopsis: A Haskell implementation of the Accentuate.us API. License: BSD3 @@ -10,9 +11,14 @@ Category: Web Build-type: Simple Extra-source-files: README.mkd -Cabal-version: >=1.2 +Cabal-version: >=1.6 +source-repository head + type: git + location: git://github.com/spearhead/hs-accentuateus.git + Library - Exposed-modules: Text.AccentuateUs - ghc-options: -Wall - Build-depends: base >= 3 && < 5, HTTP, json, network + Exposed-modules: Text.AccentuateUs + ghc-options: -Wall -fwarn-tabs + Build-depends: base >= 3 && < 5, HTTP, json, network + Hs-Source-Dirs: src diff --git a/src/Text/AccentuateUs.hs b/src/Text/AccentuateUs.hs new file mode 100644 --- /dev/null +++ b/src/Text/AccentuateUs.hs @@ -0,0 +1,159 @@ +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 + +-- | Get langs and their localized names +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." + +-- | For a given language, and optionally a locale, accentuates text +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 + +-- | Submits corrected text as feedback to Accentuate.us +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." + +-- | Encapsulates various properties of an Accentuate.us API call +data Param + = PCall String + | PCode Integer + | PText String + | PLang Lang + | PLocale Locale + | PVersion Int + deriving (Show) + +-- | Represents responses for the three Accentuate.us calls +data AUSResponse + = Langs { status :: LangsStatus + , version :: Int + , languages :: [(String, Lang)] -- ^ [(ISO-639, Localized Language)] + } + | Lift { text :: String } + | Feedback + deriving Show + +-- | Represents languages response status +data LangsStatus = OutOfDate -- ^ Given version number < server's + | UpToDate -- ^ Given version number == server's + | OverDate -- ^ Given version number > server's + 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 + +-- | Converts integer response code into data type LangsStatus +codeToStatus :: Int -> Maybe LangsStatus +codeToStatus c = case c of + 100 -> Just OutOfDate + 200 -> Just UpToDate + 400 -> Just OverDate + _ -> Nothing + +-- | Splits a string pair (separated by :) into a tuple, removing separator +splitPair :: String -> (String, String) +splitPair s = removeSep $ break (== ':') s + where removeSep (a,b) = (a, tail b) + +-- | Sends response to server +post :: [Param] -> IO String +post ps = (simpleHTTP . prepRequest $ ps) >>= \r -> getResponseBody r + +-- | Create request +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) + +-- | Map parameters to call-appropriate tuples +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) + +-- | Common response parsing +eitherDecode :: (JSON a) => String -> Either String a +eitherDecode = resultToEither . decode + +-- | Conversion from optional locale parameter to (empty) string. +mbLocale :: Maybe String -> String +mbLocale = fromMaybe "" + +-- | Generate appropriate headers +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 + +-- | Generate language-specific URL +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