diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Ernesto Rodriguez + +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 Ernesto Rodriguez 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/MicrosoftTranslator.cabal b/MicrosoftTranslator.cabal new file mode 100644 --- /dev/null +++ b/MicrosoftTranslator.cabal @@ -0,0 +1,50 @@ +-- Initial BingTranslate.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: MicrosoftTranslator +version: 0.1.0.0 +synopsis: Interface for Microsoft Translator +description: + A simple library to use Microsoft Translator + () in Haskell. + It provides an easy to use interface to the free translation service from + Microsoft so one can easily add language translation to a Haskell program + as long as there is internet connection available. + + The easiest way to use the program is via the toplevel translate function: + > translate :: ClientId -> ClientSecret -> Text -> BingLanguage -> BingLanguage -> IO (Either BingError Text) + + To use this library one must have an account for Microsoft Translator in the + Azure Data Market. More information about this package available at: (). + +license: BSD3 +license-file: LICENSE +author: Ernesto Rodriguez +maintainer: neto@netowork.me +-- copyright: +category: Language +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/netogallo/Microsoft-Translator-Haskell.git + +library + exposed-modules: Language.Bing + -- other-modules: + -- other-extensions: + build-depends: base >=4.8 && <4.9 + , wreq >= 0.4.0.0 + , bytestring >= 0.10.0 + , exceptions >= 0.8.0 + , lens >= 4.12.0 + , transformers >= 0.4.3.0 + , http-client >= 0.4.16 + , aeson >= 0.9.0 + , datetime >= 0.2.1 + , text >= 1.2.0 + , url >= 2.1.0 + , xml >= 1.3.0 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Language/Bing.hs b/src/Language/Bing.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bing.hs @@ -0,0 +1,214 @@ +{-# Language RecordWildCards, OverloadedStrings, DeriveDataTypeable #-} +module Language.Bing( + BingLanguage(..), + BingError(..), + ClientId, + ClientSecret, + checkToken, + evalBing, + getAccessToken, + runBing, + translate, + translateM) where + +import qualified Network.Wreq as N +import Network.Wreq.Types (Postable) +import Control.Lens +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack,unpack) +import Control.Monad.Catch +import Data.Typeable (Typeable) +import Control.Monad.IO.Class +import Network.HTTP.Client (HttpException) +import qualified Control.Exception as E +import Control.Monad.Trans.Except +import Control.Monad.Trans.Class +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.Aeson +import Control.Monad (mzero) +import Control.Applicative ((<$>),(<*>)) +import Data.Monoid +import Control.Applicative +import Data.DateTime +import Data.Text (Text) +import qualified Data.Text as T +import Network.URL (decString) +import Text.XML.Light.Input +import Text.XML.Light.Types +import Text.XML.Light.Proc +import Data.List (find) +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +import System.IO.Unsafe (unsafePerformIO) + +type ClientId = ByteString + +type ClientSecret = ByteString + +data BingError = BingError ByteString + deriving (Typeable, Show) + +-- | The languages available for Microsoft Translatorj +data BingLanguage = English + | German + | Norwegian + | Spanish + +-- | Conversion function from Language to language code +toSym bl = case bl of + English -> "en" + German -> "de" + Norwegian -> "no" + Spanish -> "es" + +data AccessToken = AccessToken { + tokenType :: ByteString, + token :: ByteString, + expires :: Integer, + scope :: ByteString + } deriving Show + +data BingContext = BCTX { + accessToken :: AccessToken, + inception :: DateTime, + clientId :: ByteString, + clientSecret :: ByteString + } deriving Show + +newtype BingMonad a = BM {runBing :: BingContext -> ExceptT BingError IO a} + +instance Monad BingMonad where + m >>= f = BM (\ctx' -> do + ctx <- checkToken ctx' + res <- runBing m ctx + runBing (f res) ctx) + + return a = BM $ \ctx -> return a + +instance Functor BingMonad where + fmap f bm = do + v <- bm + return $ f v + +instance Applicative BingMonad where + pure a = return a + a <*> b = do + a' <- a + b' <- b + return (a' b') + +instance FromJSON AccessToken where + parseJSON (Object v) = build <$> + v .: "token_type" <*> + v .: "access_token" <*> + ((v .: "expires_in") >>= getNum) <*> + v .: "scope" + + where + getNum str = case decode (BLC.pack str) of + Just n -> return n + Nothing -> mzero + build :: String -> String -> Integer -> String -> AccessToken + build v1 v2 v3 v4 = AccessToken (pack v1) (pack v2) v3 (pack v4) + parseJSON _ = mzero + +instance Exception BingError + +scopeArg = ("scope" :: ByteString) + N.:= ("http://api.microsofttranslator.com" :: ByteString) + +grantType = ("grant_type" :: ByteString) + N.:= ("client_credentials" :: ByteString) + +tokenAuthPage :: String +tokenAuthPage = "https://datamarket.accesscontrol.windows.net/v2/OAuth2-13" + +translateUrl :: String +translateUrl = "http://api.microsofttranslator.com/v2/Http.svc/Translate" +-- translateUrl = "http://requestb.in/14zmco81" + +translateArgs text from to = [ + ("text" N.:= (text :: ByteString)), + ("from" N.:= (toSym from :: ByteString)), + ("to" N.:= (toSym to :: ByteString)) + ] + +bingAction :: IO (N.Response BL.ByteString) -> ExceptT BingError IO (N.Response BL.ByteString) +bingAction action = do + res <- lift $ (E.try action :: IO (Either HttpException (N.Response BL.ByteString))) + case res of + Right res -> return res + Left ex -> throwE $ BingError $ pack $ show ex + +post url postable = bingAction (N.post url postable) + +postWith opts url postable = bingAction (N.postWith opts url postable) + +getWithAuth opts' url = withContext $ \BCTX{..} -> do + let opts = opts' & N.header "Authorization" .~ ["Bearer " <> token accessToken] + bingAction (N.getWith opts url) + +-- | Request a new access token from Azure using the specified client +-- id and client secret +getAccessToken :: ByteString -> ByteString -> ExceptT BingError IO BingContext +getAccessToken clientId clientSecret = do + req <- post tokenAuthPage [ + "client_id" N.:= clientId, + "client_secret" N.:= clientSecret, + scopeArg, + grantType + ] + r <- N.asJSON req + let t = r ^. N.responseBody + t' <- liftIO $ getCurrentTime + return $ BCTX{ + accessToken = t, + inception = t', + clientId = clientId, + clientSecret = clientSecret + } + +-- | Check if the access token of the running BingAction is still +-- valid. If the token has expired, renews the token automatically +checkToken :: BingContext -> ExceptT BingError IO BingContext +checkToken ctx@BCTX{..} = do + t <- liftIO $ getCurrentTime + if diffSeconds t inception > expires accessToken - 100 then do + BCTX{accessToken = tk} <- getAccessToken clientId clientSecret + t' <- liftIO $ getCurrentTime + return $ ctx{accessToken = tk, inception = t'} + else + return $ ctx + +withContext = BM + +-- | Action that translates text inside a BingMonad context. +translateM :: Text -> BingLanguage -> BingLanguage -> BingMonad Text +translateM text from to = do + let opts = N.defaults & N.param "from" .~ [toSym from :: Text] + & N.param "to" .~ [toSym to] + & N.param "contentType" .~ ["text/plain"] + & N.param "category" .~ ["general"] + & N.param "text" .~ [text] + res <- getWithAuth opts translateUrl + let trans = parseXML $ (TE.decodeUtf8 $ BLC.toStrict $ res ^. N.responseBody) + case find (\n -> case n of + Elem e -> "string" == (qName $ elName e) + _ -> False) trans of + Just (Elem e) -> return $ T.pack $ strContent e + _ -> BM $ \_ -> throwE $ BingError $ pack $ show res + +-- | Helper function that evaluates a BingMonad action. It simply +-- requests and access token and uses the token for evaluation. +evalBing :: ClientId -> ClientSecret -> BingMonad a -> IO (Either BingError a) +evalBing clientId clientSecret action = runExceptT $ do + t <- getAccessToken clientId clientSecret + runBing action t + +-- | Toplevel wrapper that translates a text. It is only recommended if translation +-- is invoked less often than every 10 minutes since it always +-- requests a new access token. For better performance use +-- translateM, runBing and getAccessToken +translate :: ClientId -> ClientSecret -> Text -> BingLanguage -> BingLanguage -> IO (Either BingError Text) +translate cid cs text from to = evalBing cid cs (translateM text from to)