packages feed

bluemix-sdk (empty) → 0.1.0.0

raw patch · 7 files changed

+333/−0 lines, 7 filesdep +aesondep +basedep +http-clientsetup-changed

Dependencies added: aeson, base, http-client, http-types, text, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Alexander Thiemann (c) 2017++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 Alexander Thiemann 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.
+ README.md view
@@ -0,0 +1,3 @@+# bluemix-sdk++API Bindings to IBM bluemix/watson. Note that I am currently only implementing what I personally use, so feel free to extend via PR.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bluemix-sdk.cabal view
@@ -0,0 +1,31 @@+name:                bluemix-sdk+version:             0.1.0.0+synopsis:            Bindings to Bluemix APIs+description:         Bindings to Bluemix APIs+homepage:            https://github.com/agrafix/bluemix-sdk#readme+license:             BSD3+license-file:        LICENSE+author:              Alexander Thiemann+maintainer:          mail@athiemann.net+copyright:           2017 Alexander Thiemann <mail@athiemann.net>+category:            Web+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Network.Watson.NaturalLanguage,+                       Network.Bluemix.Auth+  other-modules:       Network.Bluemix.Http+  build-depends:       base >= 4.7 && < 5,+                       aeson,+                       text,+                       vector,+                       http-types,+                       http-client+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/agrafix/bluemix-sdk
+ src/Network/Bluemix/Auth.hs view
@@ -0,0 +1,12 @@+module Network.Bluemix.Auth where++import Network.HTTP.Client+import qualified Data.Text as T++data Auth service+    = Auth+    { a_username :: !T.Text+    , a_password :: !T.Text+    , a_url :: !T.Text+    , a_manager :: !Manager+    }
+ src/Network/Bluemix/Http.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Bluemix.Http+    ( runReq+    , Result(..)+    , Manager+    )+where++import Network.Bluemix.Auth++import Data.Aeson (eitherDecode, encode, ToJSON, FromJSON)+import Network.HTTP.Client+import Network.HTTP.Types+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++data Result r+    = ROkay r+    | RBadResponse !T.Text+    | RBadStatus !Status+    deriving (Show, Eq)++runReq :: (ToJSON req, FromJSON r) => Method -> Auth a -> T.Text -> req -> IO (Result r)+runReq meth auth url requestObject =+    do initialRequest <-+           applyBasicAuth+           (T.encodeUtf8 (a_username auth)) (T.encodeUtf8 (a_password auth))+           <$> parseRequest (T.unpack url)+       let request =+               initialRequest+               { method = meth+               , requestBody = RequestBodyLBS $ encode requestObject+               , requestHeaders =+                       (requestHeaders initialRequest)+                       ++ [("Content-Type", "application/json")]+               }+       response <- httpLbs request $ a_manager auth+       let rs = responseStatus response+       case statusCode rs of+         200 ->+             case eitherDecode (responseBody response) of+               Left errMsg -> pure (RBadResponse $ T.pack errMsg)+               Right ok -> pure (ROkay ok)+         _ -> pure $ RBadStatus rs
+ src/Network/Watson/NaturalLanguage.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Watson.NaturalLanguage+    ( -- * Request+      QueryBody(..)+    , KeywordOptions(..)+    , ConceptOptions(..)+    , Query(..)+      -- * Response+    , Emotion(..)+    , Sentiment(..)+    , Keyword(..)+    , Concept(..)+    , Category(..)+    , Response(..)+    , Language(..)+      -- * API Call+    , NaturalLanguage, makeAuth, Auth(..), naturalLanguage, Result(..)+    )+where++import Network.Bluemix.Auth+import Network.Bluemix.Http++import Data.Aeson hiding (Result(..))+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Vector as V++data QueryBody+    = QBText !T.Text+    | QBHtml !T.Text+    | QBUrl !T.Text+    deriving (Show, Eq)++data KeywordOptions+    = KeywordOptions+    { ko_emotion :: !Bool+    , ko_sentiment :: !Bool+    , ko_limit :: !Int+    } deriving (Show, Eq)++data ConceptOptions+    = ConceptOptions+    { co_limit :: !Int+    } deriving (Show, Eq)++data Query+    = Query+    { q_body :: !QueryBody+    , q_keywords :: !(Maybe KeywordOptions)+    , q_categories :: !Bool+    , q_concepts :: !(Maybe ConceptOptions)+    } deriving (Show, Eq)++instance ToJSON Query where+    toJSON q =+        let body =+                case q_body q of+                  QBText t -> "text" .= t+                  QBHtml t -> "html" .= t+                  QBUrl t -> "url" .= t+            feats =+                object $+                catMaybes+                [ flip fmap (q_keywords q) $ \kwds ->+                  "keywords" .=+                    object+                    [ "sentiment" .= ko_sentiment kwds+                    , "emotion" .= ko_emotion kwds+                    , "limit" .= ko_limit kwds+                    ]+                , flip fmap (q_concepts q) $ \cp ->+                  "concepts" .=+                    object+                    [ "limit" .= co_limit cp+                    ]+                , if q_categories q then (Just $ "categories" .= object []) else Nothing+                ]+        in object [body, "features" .= feats]++data Emotion+    = Emotion+    { e_sadness :: !Double+    , e_joy :: !Double+    , e_disgust :: !Double+    , e_anger :: !Double+    } deriving (Show, Eq)++instance FromJSON Emotion where+    parseJSON =+        withObject "Emotion" $ \o ->+        Emotion+        <$> o .: "sadness"+        <*> o .: "joy"+        <*> o .: "disgust"+        <*> o .: "anger"++newtype Sentiment+    = Sentiment { unSentiment :: Double }+    deriving (Show, Eq)++instance FromJSON Sentiment where+    parseJSON =+        withObject "Sentiment" $ \o ->+        Sentiment <$> o .: "score"++data Keyword+    = Keyword+    { k_keyword :: !T.Text+    , k_relevance :: !Double+    , k_sentiment :: !(Maybe Sentiment)+    , k_emotion :: !(Maybe Emotion)+    } deriving (Show, Eq)++instance FromJSON Keyword where+    parseJSON =+        withObject "Keyword" $ \o ->+        Keyword+        <$> o .: "text"+        <*> o .: "relevance"+        <*> o .:? "sentiment"+        <*> o .:? "emotion"++data Concept+    = Concept+    { c_concept :: !T.Text+    , c_relevance :: Double+    , c_dbpedia :: !T.Text+    } deriving (Show, Eq)++instance FromJSON Concept where+    parseJSON =+        withObject "Concept" $ \o ->+        Concept+        <$> o .: "text"+        <*> o .: "relevance"+        <*> o .: "dbpedia_resource"++data Category+    = Category+    { c_label :: !T.Text+    , c_score :: !Double+    } deriving (Show, Eq)++instance FromJSON Category where+    parseJSON =+        withObject "Category" $ \o ->+        Category+        <$> o .: "label"+        <*> o .: "score"++data Language+    = LArabic+    | LEnglish+    | LFrench+    | LGerman+    | LItalian+    | LPortuguese+    | LRussian+    | LSpanish+    | LSwedish+    deriving (Show, Eq)++instance FromJSON Language where+    parseJSON =+        withText "Language" $ \t ->+        case t of+          "ar" -> pure LArabic+          "en" -> pure LEnglish+          "fr" -> pure LFrench+          "de" -> pure LGerman+          "it" -> pure LItalian+          "pt" -> pure LPortuguese+          "ru" -> pure LRussian+          "es" -> pure LSpanish+          "sv" -> pure LSwedish+          _ -> fail ("Unsupported language: " ++ show t)++data Response+    = Response+    { r_language :: !Language+    , r_keywords :: !(V.Vector Keyword)+    , r_concepts :: !(V.Vector Concept)+    , r_categories :: !(V.Vector Category)+    } deriving (Show, Eq)++instance FromJSON Response where+    parseJSON =+        withObject "Response" $ \o  ->+        Response+        <$> o .: "language"+        <*> o .:? "keywords" .!= V.empty+        <*> o .:? "concepts" .!= V.empty+        <*> o .:? "categories" .!= V.empty++data NaturalLanguage++makeAuth :: Manager -> T.Text -> T.Text -> Auth NaturalLanguage+makeAuth mgr user pass =+    Auth+    { a_username = user+    , a_password = pass+    , a_url = apiEndpointUrl+    , a_manager = mgr+    }++apiEndpointUrl :: T.Text+apiEndpointUrl = "https://gateway.watsonplatform.net/natural-language-understanding/api/v1/analyze?version=2017-02-27"++naturalLanguage :: Auth NaturalLanguage -> Query -> IO (Result Response)+naturalLanguage auth = runReq "POST" auth (a_url auth)