2017-03-08 21:33:55 +03:00
|
|
|
-- Copyright (c) 2016-present, Facebook, Inc.
|
|
|
|
-- All rights reserved.
|
|
|
|
--
|
|
|
|
-- This source code is licensed under the BSD-style license found in the
|
2019-05-22 20:36:43 +03:00
|
|
|
-- LICENSE file in the root directory of this source tree.
|
2017-03-08 21:33:55 +03:00
|
|
|
|
|
|
|
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2021-03-16 22:59:13 +03:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2020-12-15 01:54:06 +03:00
|
|
|
{-# LANGUAGE TypeApplications #-}
|
2017-03-08 21:33:55 +03:00
|
|
|
|
2018-03-20 00:34:58 +03:00
|
|
|
import Control.Applicative hiding (empty)
|
2017-04-07 02:51:36 +03:00
|
|
|
import Control.Arrow ((***))
|
2021-03-16 22:59:13 +03:00
|
|
|
import Control.Exception (SomeException, catch)
|
2021-01-29 22:24:39 +03:00
|
|
|
import Control.Monad (unless, when)
|
2017-04-07 02:51:36 +03:00
|
|
|
import Control.Monad.IO.Class
|
|
|
|
import Data.Aeson
|
2018-03-20 00:34:58 +03:00
|
|
|
import Data.ByteString (ByteString, empty)
|
2017-04-07 02:51:36 +03:00
|
|
|
import Data.HashMap.Strict (HashMap)
|
|
|
|
import Data.Maybe
|
Locales support
Summary:
* Locales support for the library, following `<Lang>_<Region>` with ISO 639-1 code for `<Lang>` and ISO 3166-1 alpha-2 code for `<Region>` (#33)
* `Locale` opaque type (composite of `Lang` and `Region`) with `makeLocale` smart constructor to only allow valid `(Lang, Region)` combinations
* API: `Context`'s `lang` parameter has been replaced by `locale`, with optional `Region` and backward compatibility.
* `Rules/<Lang>.hs` exposes
- `langRules`: cross-locale rules for `<Lang>`, from `<Dimension>/<Lang>/Rules.hs`
- `localeRules`: locale-specific rules, from `<Dimension>/<Lang>/<Region>/Rules.hs`
- `defaultRules`: `langRules` + specific rules from select locales to ensure backward-compatibility
* Corpus, tests & classifiers
- 1 classifier per locale, with default classifier (`<Lang>_XX`) when no locale provided (backward-compatible)
- Default classifiers are built on existing corpus
- Locale classifiers are built on
- `<Dimension>/<Lang>/Corpus.hs` exposes a common `corpus` to all locales of `<Lang>`
- `<Dimension>/<Lang>/<Region>/Corpus.hs` exposes `allExamples`: a list of examples specific to the locale (following `<Dimension>/<Lang>/<Region>/Rules.hs`).
- Locale classifiers use the language corpus extended with the locale examples as training set.
- Locale examples need to use the same `Context` (i.e. reference time) as the language corpus.
- For backward compatibility, `<Dimension>/<Lang>/Corpus.hs` can expose also `defaultCorpus`, which is `corpus` augmented with specific examples. This is controlled by `getDefaultCorpusForLang` in `Duckling.Ranking.Generate`.
- Tests run against each classifier to make sure runtime works as expected.
* MM/DD (en_US) vs DD/MM (en_GB) example to illustrate
Reviewed By: JonCoens, blandinw
Differential Revision: D6038096
fbshipit-source-id: f29c28d
2017-10-13 18:15:32 +03:00
|
|
|
import Data.String
|
2017-04-07 02:51:36 +03:00
|
|
|
import Data.Text (Text)
|
|
|
|
import Data.Time.LocalTime.TimeZone.Series
|
2017-06-14 11:57:43 +03:00
|
|
|
import Prelude
|
|
|
|
import System.Directory
|
2018-12-12 22:04:51 +03:00
|
|
|
import System.Environment (lookupEnv)
|
2017-04-07 02:51:36 +03:00
|
|
|
import TextShow
|
|
|
|
import Text.Read (readMaybe)
|
2017-06-14 11:57:43 +03:00
|
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Data.Text.Encoding as Text
|
2017-04-07 02:51:36 +03:00
|
|
|
|
2018-01-10 23:39:50 +03:00
|
|
|
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
2017-04-07 02:51:36 +03:00
|
|
|
import Snap.Core
|
|
|
|
import Snap.Http.Server
|
2017-03-08 21:33:55 +03:00
|
|
|
|
|
|
|
import Duckling.Core
|
|
|
|
import Duckling.Data.TimeZone
|
2020-12-15 01:54:06 +03:00
|
|
|
import Duckling.Dimensions (allDimensions)
|
2018-01-10 23:39:50 +03:00
|
|
|
import Duckling.Resolve (DucklingTime)
|
2017-03-08 21:33:55 +03:00
|
|
|
|
2017-06-14 11:57:43 +03:00
|
|
|
createIfMissing :: FilePath -> IO ()
|
|
|
|
createIfMissing f = do
|
|
|
|
exists <- doesFileExist f
|
|
|
|
unless exists $ writeFile f ""
|
|
|
|
|
2021-01-29 22:24:39 +03:00
|
|
|
shouldLog :: Maybe ConfigLog -> Bool
|
|
|
|
shouldLog Nothing = False
|
|
|
|
shouldLog (Just ConfigNoLog) = False
|
|
|
|
shouldLog _ = True
|
|
|
|
|
|
|
|
setupLogs :: Config a b -> IO ()
|
|
|
|
setupLogs conf = do
|
|
|
|
let shouldLogErrors = shouldLog $ getErrorLog conf
|
|
|
|
let shouldLogAccesses = shouldLog $ getAccessLog conf
|
|
|
|
|
|
|
|
when (shouldLogErrors || shouldLogAccesses) $ createDirectoryIfMissing False "log"
|
|
|
|
when shouldLogErrors $ createIfMissing "log/error.log"
|
|
|
|
when shouldLogAccesses $ createIfMissing "log/access.log"
|
2017-06-14 11:57:43 +03:00
|
|
|
|
2021-03-16 22:59:13 +03:00
|
|
|
loadTZs :: IO (HashMap Text TimeZoneSeries)
|
|
|
|
loadTZs = do
|
|
|
|
let defaultPath = "/usr/share/zoneinfo/"
|
|
|
|
let fallbackPath = "/etc/zoneinfo/"
|
|
|
|
loadTimeZoneSeries defaultPath `catch` (\(_ :: SomeException) -> loadTimeZoneSeries fallbackPath)
|
|
|
|
|
2017-03-08 21:33:55 +03:00
|
|
|
main :: IO ()
|
|
|
|
main = do
|
2021-03-16 22:59:13 +03:00
|
|
|
tzs <- loadTZs
|
2018-12-12 22:04:51 +03:00
|
|
|
p <- lookupEnv "PORT"
|
|
|
|
conf <- commandLineConfig $
|
|
|
|
maybe defaultConfig (`setPort` defaultConfig) (readMaybe =<< p)
|
2021-01-29 22:24:39 +03:00
|
|
|
setupLogs conf
|
2018-12-12 22:04:51 +03:00
|
|
|
httpServe conf $
|
2017-04-07 02:51:36 +03:00
|
|
|
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
|
2020-09-28 11:31:58 +03:00
|
|
|
dimText :: (Lang, [Seal Dimension]) -> (Text, [Text])
|
|
|
|
dimText = (Text.toLower . showt) *** map (\(Seal d) -> toName d)
|
2017-04-07 02:51:36 +03:00
|
|
|
|
|
|
|
|
|
|
|
-- | 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"
|
Locales support
Summary:
* Locales support for the library, following `<Lang>_<Region>` with ISO 639-1 code for `<Lang>` and ISO 3166-1 alpha-2 code for `<Region>` (#33)
* `Locale` opaque type (composite of `Lang` and `Region`) with `makeLocale` smart constructor to only allow valid `(Lang, Region)` combinations
* API: `Context`'s `lang` parameter has been replaced by `locale`, with optional `Region` and backward compatibility.
* `Rules/<Lang>.hs` exposes
- `langRules`: cross-locale rules for `<Lang>`, from `<Dimension>/<Lang>/Rules.hs`
- `localeRules`: locale-specific rules, from `<Dimension>/<Lang>/<Region>/Rules.hs`
- `defaultRules`: `langRules` + specific rules from select locales to ensure backward-compatibility
* Corpus, tests & classifiers
- 1 classifier per locale, with default classifier (`<Lang>_XX`) when no locale provided (backward-compatible)
- Default classifiers are built on existing corpus
- Locale classifiers are built on
- `<Dimension>/<Lang>/Corpus.hs` exposes a common `corpus` to all locales of `<Lang>`
- `<Dimension>/<Lang>/<Region>/Corpus.hs` exposes `allExamples`: a list of examples specific to the locale (following `<Dimension>/<Lang>/<Region>/Rules.hs`).
- Locale classifiers use the language corpus extended with the locale examples as training set.
- Locale examples need to use the same `Context` (i.e. reference time) as the language corpus.
- For backward compatibility, `<Dimension>/<Lang>/Corpus.hs` can expose also `defaultCorpus`, which is `corpus` augmented with specific examples. This is controlled by `getDefaultCorpusForLang` in `Duckling.Ranking.Generate`.
- Tests run against each classifier to make sure runtime works as expected.
* MM/DD (en_US) vs DD/MM (en_GB) example to illustrate
Reviewed By: JonCoens, blandinw
Differential Revision: D6038096
fbshipit-source-id: f29c28d
2017-10-13 18:15:32 +03:00
|
|
|
loc <- getPostParam "locale"
|
2018-01-10 23:39:50 +03:00
|
|
|
ref <- getPostParam "reftime"
|
2018-03-20 00:34:58 +03:00
|
|
|
latent <- getPostParam "latent"
|
2017-04-07 02:51:36 +03:00
|
|
|
|
|
|
|
case t of
|
|
|
|
Nothing -> do
|
|
|
|
modifyResponse $ setResponseStatus 422 "Bad Input"
|
|
|
|
writeBS "Need a 'text' parameter to parse"
|
|
|
|
Just tx -> do
|
2018-01-10 23:39:50 +03:00
|
|
|
let timezone = parseTimeZone tz
|
|
|
|
now <- liftIO $ currentReftime tzs timezone
|
2017-04-07 02:51:36 +03:00
|
|
|
let
|
2020-12-15 01:54:06 +03:00
|
|
|
lang = parseLang l
|
|
|
|
|
2017-04-07 02:51:36 +03:00
|
|
|
context = Context
|
2018-01-10 23:39:50 +03:00
|
|
|
{ referenceTime = maybe now (parseRefTime timezone) ref
|
2020-12-15 01:54:06 +03:00
|
|
|
, locale = maybe (makeLocale lang Nothing) parseLocale loc
|
2017-04-07 02:51:36 +03:00
|
|
|
}
|
2018-03-20 00:34:58 +03:00
|
|
|
options = Options {withLatent = parseLatent latent}
|
2017-04-07 02:51:36 +03:00
|
|
|
|
2020-12-15 01:54:06 +03:00
|
|
|
dims = fromMaybe (allDimensions lang) $ do
|
|
|
|
queryDims <- ds
|
|
|
|
txtDims <- decode @[Text] $ LBS.fromStrict queryDims
|
2020-12-15 22:38:02 +03:00
|
|
|
pure $ mapMaybe parseDimension txtDims
|
2017-04-07 02:51:36 +03:00
|
|
|
|
2018-03-20 00:34:58 +03:00
|
|
|
parsedResult = parse (Text.decodeUtf8 tx) context options dims
|
2017-04-07 02:51:36 +03:00
|
|
|
|
|
|
|
writeLBS $ encode parsedResult
|
|
|
|
where
|
|
|
|
defaultLang = EN
|
Locales support
Summary:
* Locales support for the library, following `<Lang>_<Region>` with ISO 639-1 code for `<Lang>` and ISO 3166-1 alpha-2 code for `<Region>` (#33)
* `Locale` opaque type (composite of `Lang` and `Region`) with `makeLocale` smart constructor to only allow valid `(Lang, Region)` combinations
* API: `Context`'s `lang` parameter has been replaced by `locale`, with optional `Region` and backward compatibility.
* `Rules/<Lang>.hs` exposes
- `langRules`: cross-locale rules for `<Lang>`, from `<Dimension>/<Lang>/Rules.hs`
- `localeRules`: locale-specific rules, from `<Dimension>/<Lang>/<Region>/Rules.hs`
- `defaultRules`: `langRules` + specific rules from select locales to ensure backward-compatibility
* Corpus, tests & classifiers
- 1 classifier per locale, with default classifier (`<Lang>_XX`) when no locale provided (backward-compatible)
- Default classifiers are built on existing corpus
- Locale classifiers are built on
- `<Dimension>/<Lang>/Corpus.hs` exposes a common `corpus` to all locales of `<Lang>`
- `<Dimension>/<Lang>/<Region>/Corpus.hs` exposes `allExamples`: a list of examples specific to the locale (following `<Dimension>/<Lang>/<Region>/Rules.hs`).
- Locale classifiers use the language corpus extended with the locale examples as training set.
- Locale examples need to use the same `Context` (i.e. reference time) as the language corpus.
- For backward compatibility, `<Dimension>/<Lang>/Corpus.hs` can expose also `defaultCorpus`, which is `corpus` augmented with specific examples. This is controlled by `getDefaultCorpusForLang` in `Duckling.Ranking.Generate`.
- Tests run against each classifier to make sure runtime works as expected.
* MM/DD (en_US) vs DD/MM (en_GB) example to illustrate
Reviewed By: JonCoens, blandinw
Differential Revision: D6038096
fbshipit-source-id: f29c28d
2017-10-13 18:15:32 +03:00
|
|
|
defaultLocale = makeLocale defaultLang Nothing
|
2017-04-07 02:51:36 +03:00
|
|
|
defaultTimeZone = "America/Los_Angeles"
|
2018-03-20 00:34:58 +03:00
|
|
|
defaultLatent = False
|
2017-04-07 02:51:36 +03:00
|
|
|
|
2020-09-28 11:31:58 +03:00
|
|
|
parseDimension :: Text -> Maybe (Seal Dimension)
|
2018-08-17 01:29:06 +03:00
|
|
|
parseDimension x = fromName x <|> fromCustomName x
|
|
|
|
where
|
2020-09-28 11:31:58 +03:00
|
|
|
fromCustomName :: Text -> Maybe (Seal Dimension)
|
2018-08-17 01:29:06 +03:00
|
|
|
fromCustomName name = HashMap.lookup name m
|
|
|
|
m = HashMap.fromList
|
|
|
|
[ -- ("my-dimension", This (CustomDimension MyDimension))
|
|
|
|
]
|
|
|
|
|
2018-01-10 23:39:50 +03:00
|
|
|
parseTimeZone :: Maybe ByteString -> Text
|
2018-12-12 22:04:51 +03:00
|
|
|
parseTimeZone = maybe defaultTimeZone Text.decodeUtf8
|
2018-01-10 23:39:50 +03:00
|
|
|
|
Locales support
Summary:
* Locales support for the library, following `<Lang>_<Region>` with ISO 639-1 code for `<Lang>` and ISO 3166-1 alpha-2 code for `<Region>` (#33)
* `Locale` opaque type (composite of `Lang` and `Region`) with `makeLocale` smart constructor to only allow valid `(Lang, Region)` combinations
* API: `Context`'s `lang` parameter has been replaced by `locale`, with optional `Region` and backward compatibility.
* `Rules/<Lang>.hs` exposes
- `langRules`: cross-locale rules for `<Lang>`, from `<Dimension>/<Lang>/Rules.hs`
- `localeRules`: locale-specific rules, from `<Dimension>/<Lang>/<Region>/Rules.hs`
- `defaultRules`: `langRules` + specific rules from select locales to ensure backward-compatibility
* Corpus, tests & classifiers
- 1 classifier per locale, with default classifier (`<Lang>_XX`) when no locale provided (backward-compatible)
- Default classifiers are built on existing corpus
- Locale classifiers are built on
- `<Dimension>/<Lang>/Corpus.hs` exposes a common `corpus` to all locales of `<Lang>`
- `<Dimension>/<Lang>/<Region>/Corpus.hs` exposes `allExamples`: a list of examples specific to the locale (following `<Dimension>/<Lang>/<Region>/Rules.hs`).
- Locale classifiers use the language corpus extended with the locale examples as training set.
- Locale examples need to use the same `Context` (i.e. reference time) as the language corpus.
- For backward compatibility, `<Dimension>/<Lang>/Corpus.hs` can expose also `defaultCorpus`, which is `corpus` augmented with specific examples. This is controlled by `getDefaultCorpusForLang` in `Duckling.Ranking.Generate`.
- Tests run against each classifier to make sure runtime works as expected.
* MM/DD (en_US) vs DD/MM (en_GB) example to illustrate
Reviewed By: JonCoens, blandinw
Differential Revision: D6038096
fbshipit-source-id: f29c28d
2017-10-13 18:15:32 +03:00
|
|
|
parseLocale :: ByteString -> Locale
|
|
|
|
parseLocale x = maybe defaultLocale (`makeLocale` mregion) mlang
|
|
|
|
where
|
|
|
|
(mlang, mregion) = case chunks of
|
|
|
|
[a, b] -> (readMaybe a :: Maybe Lang, readMaybe b :: Maybe Region)
|
|
|
|
_ -> (Nothing, Nothing)
|
|
|
|
chunks = map Text.unpack . Text.split (== '_') . Text.toUpper
|
|
|
|
$ Text.decodeUtf8 x
|
|
|
|
|
2017-04-07 02:51:36 +03:00
|
|
|
parseLang :: Maybe ByteString -> Lang
|
|
|
|
parseLang l = fromMaybe defaultLang $ l >>=
|
|
|
|
readMaybe . Text.unpack . Text.toUpper . Text.decodeUtf8
|
2018-01-10 23:39:50 +03:00
|
|
|
|
|
|
|
parseRefTime :: Text -> ByteString -> DucklingTime
|
|
|
|
parseRefTime timezone refTime = makeReftime tzs timezone utcTime
|
|
|
|
where
|
|
|
|
msec = read $ Text.unpack $ Text.decodeUtf8 refTime
|
|
|
|
utcTime = posixSecondsToUTCTime $ fromInteger msec / 1000
|
2018-03-20 00:34:58 +03:00
|
|
|
|
|
|
|
parseLatent :: Maybe ByteString -> Bool
|
|
|
|
parseLatent x = fromMaybe defaultLatent
|
|
|
|
(readMaybe (Text.unpack $ Text.toTitle $ Text.decodeUtf8 $ fromMaybe empty x)::Maybe Bool)
|