diff options
| -rw-r--r-- | Procfile | 1 | ||||
| -rw-r--r-- | app/Main.hs | 33 | ||||
| -rw-r--r-- | tomatobot.cabal | 131 |
3 files changed, 21 insertions, 144 deletions
diff --git a/Procfile b/Procfile new file mode 100644 index 0000000..4d2a4e1 --- /dev/null +++ b/Procfile @@ -0,0 +1 @@ +web: tomatobot-exe $PORT diff --git a/app/Main.hs b/app/Main.hs index 3f1dcf5..1b40313 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -23,6 +23,7 @@ import Network.HTTP.Types (status200, status500) import Network.Wai (responseBuilder, responseLBS, Response) import Network.Wai.Conduit (sourceRequestBody) import Network.Wai.Handler.Warp (run) +import System.Environment (getArgs) import Data.Message (InMessage (..)) import Data.Tomato (Tomato) @@ -31,6 +32,7 @@ import Tomato.Validate (isTomato) import qualified Data.Aeson as Ae import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified RIO.List.Partial as L' data App = App @@ -77,19 +79,24 @@ tomatoBot = do logInfo $ "All done" main :: IO () -main = run 3000 $ \request send -> do - eres <- tryAnyDeep $ do - val <- runConduit - $ sourceRequestBody request - .| sinkParser Ae.json - case Ae.fromJSON val of - Ae.Success r -> return r - Ae.Error _s -> error "handle this later" - case eres of - Left e -> send $ errorResponse e - Right inMes -> do - when (isTomato inMes) $ runApp tomatoBot - send $ validResponse inMes +main = do + args <- getArgs + when (null args) (error "no port") + let portS = readMaybe $ L'.head args + let port = maybe (error "invalid port") id portS + run port $ \request send -> do + eres <- tryAnyDeep $ do + val <- runConduit + $ sourceRequestBody request + .| sinkParser Ae.json + case Ae.fromJSON val of + Ae.Success r -> return r + Ae.Error _s -> error "handle this later" + case eres of + Left e -> send $ errorResponse e + Right inMes -> do + when (isTomato inMes) $ runApp tomatoBot + send $ validResponse inMes where errorResponse :: SomeException -> Response errorResponse e = responseLBS diff --git a/tomatobot.cabal b/tomatobot.cabal deleted file mode 100644 index f4202d1..0000000 --- a/tomatobot.cabal +++ /dev/null @@ -1,131 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.34.4. --- --- see: https://github.com/sol/hpack - -name: tomatobot -version: 0.1.0.0 -description: Please see the README on GitHub at <https://github.com/githubuser/tomatobot#readme> -homepage: https://github.com/githubuser/tomatobot#readme -bug-reports: https://github.com/githubuser/tomatobot/issues -author: Author name here -maintainer: example@example.com -copyright: 2022 Author name here -license: BSD3 -build-type: Simple -extra-source-files: - README.md - -source-repository head - type: git - location: https://github.com/githubuser/tomatobot - -library - exposed-modules: - Data.Message - Data.Tomato - Tomato.Post - Tomato.Validate - other-modules: - Paths_tomatobot - hs-source-dirs: - src - default-extensions: - ApplicativeDo - BangPatterns - ConstraintKinds - DataKinds - EmptyCase - ExistentialQuantification - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PatternSynonyms - PolyKinds - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StandaloneKindSignatures - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -Wmissing-local-signatures -Wmissing-export-lists -Wpartial-fields -Wmonomorphism-restriction -Widentities -Wno-unticked-promoted-constructors -fprint-expanded-synonyms - build-depends: - aeson - , base >=4.7 && <5 - , bytestring - , conduit - , conduit-extra - , http-types - , modern-uri - , req - , rio - , unliftio - , wai - , wai-conduit - , warp - default-language: Haskell2010 - -executable tomatobot-exe - main-is: Main.hs - other-modules: - Paths_tomatobot - hs-source-dirs: - app - default-extensions: - ApplicativeDo - BangPatterns - ConstraintKinds - DataKinds - EmptyCase - ExistentialQuantification - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PatternSynonyms - PolyKinds - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StandaloneKindSignatures - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -Wmissing-local-signatures -Wmissing-export-lists -Wpartial-fields -Wmonomorphism-restriction -Widentities -Wno-unticked-promoted-constructors -fprint-expanded-synonyms -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson - , base >=4.7 && <5 - , bytestring - , conduit - , conduit-extra - , http-types - , modern-uri - , req - , rio - , tomatobot - , unliftio - , wai - , wai-conduit - , warp - default-language: Haskell2010 |