Simple example HTTP server

Summary: Runs a `snap` server to return the support targets as well as do parsing. It's a bit cludgy, but gets the job done.

Reviewed By: patapizza

Differential Revision: D4813197

fbshipit-source-id: 0fa165b

duckling.cabal

@@ -673,25 +673,19 @@ executable duckling-example-exe
   other-modules:       Duckling.Data.TimeZone
   build-depends:       duckling
                      , base                  >= 4.8.2 && < 5.0
-                     , attoparsec            >= 0.13.1.0 && < 0.14
                      , aeson                 >= 0.11.3.0 && < 1.1
                      , bytestring            >= 0.10.6.0 && < 0.11
-                     , containers            >= 0.5.6.2 && < 0.6
-                     , deepseq               >= 1.4.1.1 && < 1.5
-                     , dependent-sum         >= 0.3.2.2 && < 0.5
                      , directory             >= 1.2.2.0 && < 1.4
                      , extra                 >= 1.4.10 && < 1.6
                      , filepath              >= 1.4.0.0 && < 1.5
-                     , hashable              >= 1.2.4.0 && < 1.3
-                     , regex-base            >= 0.93.2 && < 0.94
-                     , regex-pcre            >= 0.94.4 && < 0.95
+                     , snap-core             >= 1.0.2.0 && < 1.1
+                     , snap-server           >= 1.0.1.1 && < 1.1
                      , text                  >= 1.2.2.1 && < 1.3
                      , text-show             >= 2.1.2 && < 3.5
                      , time                  >= 1.5.0.1 && < 1.7
                      , timezone-olson        >= 0.1.7 && < 0.2
                      , timezone-series       >= 0.1.5.1 && < 0.2
                      , unordered-containers  >= 0.2.7.2 && < 0.3
-                     , vector                >= 0.11.0.0 && < 0.12
   default-language:    Haskell2010
   default-extensions:  OverloadedStrings
 

exe/ExampleMain.hs

@@ -9,7 +9,25 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 import Prelude
+import Control.Applicative
+import Control.Arrow ((***))
+import Control.Monad.IO.Class
+import Data.Aeson
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.Time.LocalTime.TimeZone.Series
 import Data.String
+import TextShow
+import Text.Read (readMaybe)
+
+import Snap.Core
+import Snap.Http.Server
 
 import Duckling.Core
 import Duckling.Data.TimeZone
@@ -17,6 +35,56 @@ import Duckling.Data.TimeZone
 main :: IO ()
 main = do
   tzs <- loadTimeZoneSeries "/usr/share/zoneinfo/"
-  refTime <- currentReftime tzs "America/Los_Angeles"
-  let context = Context {referenceTime = refTime, lang = EN}
-  print $ parse "tomorrow at 6ish pm" context [This Time]
+  quickHttpServe $
+    ifTop (writeBS "quack!") <|>
+    route
+      [ ("targets", method GET targetsHandler)
+      , ("parse", method POST $ parseHandler tzs)
+      ]
+
+-- | Return which languages have which dimensions
+targetsHandler :: Snap ()
+targetsHandler = do
+  modifyResponse $ setHeader "Content-Type" "application/json"
+  writeLBS $ encode $
+    HashMap.fromList . map dimText $ HashMap.toList supportedDimensions
+  where
+    dimText :: (Lang, [Some Dimension]) -> (Text, [Text])
+    dimText = (Text.toLower . showt) *** map (\(This d) -> toName d)
+
+
+-- | Parse some text into the given dimensions
+parseHandler :: HashMap Text TimeZoneSeries -> Snap ()
+parseHandler tzs = do
+  modifyResponse $ setHeader "Content-Type" "application/json"
+  t <- getPostParam "text"
+  l <- getPostParam "lang"
+  ds <- getPostParam "dims"
+  tz <- getPostParam "tz"
+
+  case t of
+    Nothing -> do
+      modifyResponse $ setResponseStatus 422 "Bad Input"
+      writeBS "Need a 'text' parameter to parse"
+    Just tx -> do
+      refTime <- liftIO $ currentReftime tzs $
+                   fromMaybe defaultTimeZone $ Text.decodeUtf8 <$> tz
+      let
+        context = Context
+          { referenceTime = refTime
+          , lang = parseLang l
+          }
+
+        dimParse = fromMaybe [] $ decode $ LBS.fromStrict $ fromMaybe "" ds
+        dims = mapMaybe fromName dimParse
+
+        parsedResult = parse (Text.decodeUtf8 tx) context dims
+
+      writeLBS $ encode parsedResult
+  where
+    defaultLang = EN
+    defaultTimeZone = "America/Los_Angeles"
+
+    parseLang :: Maybe ByteString -> Lang
+    parseLang l = fromMaybe defaultLang $ l >>=
+      readMaybe . Text.unpack . Text.toUpper . Text.decodeUtf8