diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Spearhead Development, L.L.C. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Spearhead Development, L.L.C. nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.mkd b/README.mkd new file mode 100644 --- /dev/null +++ b/README.mkd @@ -0,0 +1,28 @@ +Copyright (c) 2011 [Spearhead Development, L.L.C.](http://spearheaddev.com/). + +Released under the BSD3 License. Please see the included `LICENSE` file. + +Introduction +============ +This project was created by [Spearhead Development](http://spearheaddev.com/) to +implement the [Accentuate.us](http://accentuate.us/) API. + +Calls +===== + +There are three primary calls to access Accentuate.us: + +* `langs (Maybe Locale) (Version)` + + `langs (Just "en") 9` + +* `accentuate (Language) (Maybe Locale) (Text)` + + `accentuate "ga" Nothing "al chead"` + +* `feedback (Language) (Maybe Locale) (*Corrected* Text)` + + `feedback "ht" (Just "en") "lè la wè"` + +The locales are included to provide localized error messages (or, in the case +of `langs`, localized language names). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/Text/AccentuateUs.hs b/Text/AccentuateUs.hs new file mode 100644 --- /dev/null +++ b/Text/AccentuateUs.hs @@ -0,0 +1,148 @@ +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 new file mode 100644 --- /dev/null +++ b/accentuateus.cabal @@ -0,0 +1,18 @@ +Name: accentuateus +Version: 0.9 +Description: A Haskell implementation of the Accentuate.us API. +Synopsis: A Haskell implementation of the Accentuate.us API. +License: BSD3 +License-file: LICENSE +Author: Spearhead Development, L.L.C. +Maintainer: Michael Schade +Copyright: (c) 2011 Spearhead Development, L.L.C. +Category: Web +Build-type: Simple +Extra-source-files: README.mkd +Cabal-version: >=1.2 + +Library + Exposed-modules: Text.AccentuateUs + ghc-options: -Wall + Build-depends: base >= 3 && < 5, HTTP, json, network