Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft: Tools #73

Open
wants to merge 7 commits into
base: main
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion Makefile
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
.PHONY: build test run docs

build:
stack build
stack build mig-postgresql-simple

test:
stack test
Expand Down
42 changes: 6 additions & 36 deletions examples/mig-example-apps/JsonApi/Init.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,17 +4,14 @@ module Init (
) where

import Control.Monad
import Data.Aeson ((.=))
import Data.Aeson qualified as Json
import Data.IORef
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time
import Data.Yaml qualified as Yaml
import System.Log.FastLogger
import Mig.Tool.Log.Fast qualified as Log
import System.Random

import Interface
Expand All @@ -38,18 +35,15 @@ initEnv port = do

initProc :: Int -> IO Proc
initProc port = do
(writeLog, closeLogger) <- newFastLogger (LogStdout defaultBufSize)
let logger = initLogger writeLog

logMessage :: Text -> IO ()
logMessage msg = logger.info $ Json.toJSON msg
logger <- Log.newLoggerStdout Log.LogYaml
let Log.LogFuns{..} = Log.logFuns logger
pure $
Proc
{ logger = logger
, startup = logMessage $ ("App starts on port: " <> Text.pack (show port))
, startup = logInfo @Text $ ("App starts on port: " <> Text.pack (show port))
, cleanup = do
logMessage "App shutdown"
closeLogger
logInfo @Text "App shutdown"
logger.close.run
}

initAuth :: St -> Auth
Expand Down Expand Up @@ -82,30 +76,6 @@ toDaySpan day (DayInterval count) = List.unfoldr go (day, count)
| n <= 0 = Nothing
| otherwise = Just (succ d, (succ d, n - 1))

initLogger :: (LogStr -> IO ()) -> Logger
initLogger writeLog =
Logger
{ error = logBy "ERROR"
, info = logBy "INFO"
, debug = logBy "DEBUG"
}
where
logBy :: Text -> LogFun
logBy level msg = do
now <- getCurrentTime
writeLog $
toLogStr $
(<> "\n") $
Yaml.encode $
Json.object
[ "log"
.= Json.object
[ "message" .= msg
, "level" .= level
, "time" .= now
]
]

initStateConfig :: IO InitSt
initStateConfig = do
now <- (.utctDay) <$> getCurrentTime
Expand Down
32 changes: 7 additions & 25 deletions examples/mig-example-apps/JsonApi/Interface.hs
Original file line number Diff line number Diff line change
@@ -1,18 +1,18 @@
module Interface (
Env (..),
LogFun,
Proc (..),
Logger (..),
logInfo,
logDebug,
logError,
Auth (..),
Weather (..),
getLogger,
module X,
) where

import Data.Aeson (ToJSON (..), Value)
import Mig.Tool.Log as X (Log, LogFuns (..), LogNamespace, addLogNamespace, logFuns)
import Types

getLogger :: Env -> LogNamespace -> LogFuns
getLogger env ns = logFuns (addLogNamespace ns env.proc.logger)

-- | Site's environment. It contains all interfaces
data Env = Env
{ weather :: Weather
Expand All @@ -24,25 +24,7 @@ data Env = Env
data Proc = Proc
{ startup :: IO ()
, cleanup :: IO ()
, logger :: Logger
}

type LogFun = Value -> IO ()

logInfo :: (ToJSON a) => Env -> a -> IO ()
logInfo env = env.proc.logger.info . toJSON

logDebug :: (ToJSON a) => Env -> a -> IO ()
logDebug env = env.proc.logger.debug . toJSON

logError :: (ToJSON a) => Env -> a -> IO ()
logError env = env.proc.logger.error . toJSON

-- logger interface
data Logger = Logger
{ info :: LogFun
, debug :: LogFun
, error :: LogFun
, logger :: Log
}

-- authorization interface
Expand Down
21 changes: 15 additions & 6 deletions examples/mig-example-apps/JsonApi/Server.hs
Original file line number Diff line number Diff line change
Expand Up @@ -32,7 +32,9 @@ server env =
, "update" /. updateWeather env
]

withTrace = applyPlugin (Trace.logHttpBy (logInfo env) Trace.V2)
withTrace = applyPlugin (Trace.logHttpBy logInfo Trace.V2)

LogFuns{..} = getLogger env "http"

-------------------------------------------------------------------------------------
-- application handlers
Expand All @@ -44,36 +46,42 @@ getWeather ::
Capture "day-interval" DayInterval ->
Get (RespOr Text (Timed WeatherData))
getWeather env (Capture location) (Capture fromDay) (Capture interval) = Send $ do
logInfo @Text env "get the weather forecast"
logInfo @Text "get the weather forecast"
mResult <- env.weather.get location fromDay interval
pure $ case mResult of
Just result -> ok result
Nothing -> bad status400 "No data"
where
LogFuns{..} = getLogger env "getWeather"

updateWeather ::
Env ->
Body UpdateData ->
Post (RespOr Text ())
updateWeather env (Body updateData) = Send $ do
logInfo @Text env "update the weather data"
logInfo @Text "update the weather data"
ok <$> env.weather.update updateData
where
LogFuns{..} = getLogger env "updateWeather"

-------------------------------------------------------------------------------------
-- authorization

requestAuthToken :: Env -> Body User -> Post (RespOr Text AuthToken)
requestAuthToken env (Body user) = Send $ do
logInfo env ("get new auth token for: " <> user.name)
logInfo ("get new auth token for: " <> user.name)
isValid <- env.auth.validUser user
if isValid
then do
token <- env.auth.newToken user
void $ forkIO $ setExpireTimer token
pure $ ok token
else do
logError env $ Text.unwords ["User", user.name, "does not have access to the service"]
logError $ Text.unwords ["User", user.name, "does not have access to the service"]
pure $ bad unauthorized401 "User is not valid"
where
LogFuns{..} = getLogger env "requestAuthToken"

setExpireTimer :: AuthToken -> IO ()
setExpireTimer token = do
threadDelay (1_000_000 * 60 * 10) -- 10 minutes
Expand All @@ -85,7 +93,8 @@ withAuth env (Header token) = processResponse $ \getResp -> do
if isOk
then getResp
else do
logError env errMessage
logError errMessage
pure $ Just (bad status500 $ Text.encodeUtf8 errMessage)
where
errMessage = "Token is invalid"
LogFuns{..} = getLogger env "auth"
3 changes: 2 additions & 1 deletion examples/mig-example-apps/mig-example-apps.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -306,13 +306,14 @@ executable json-api-mig-example-app
, bytestring
, containers
, derive-topdown
, fast-logger
, http-types
, mig
, mig-client
, mig-extra
, mig-fast-logger
, mig-server
, mig-swagger-ui
, mig-tools
, openapi3
, pretty-simple
, random
Expand Down
3 changes: 2 additions & 1 deletion examples/mig-example-apps/package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -119,7 +119,8 @@ executables:
- -with-rtsopts=-N
dependencies:
- containers
- fast-logger
- mig-tools
- mig-fast-logger
- yaml

counter-mig-example-app:
Expand Down
2 changes: 2 additions & 0 deletions examples/mig-example-apps/stack.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -11,3 +11,5 @@ extra-deps:
- ../../mig-swagger-ui
- ../../mig-wai
- ../../mig-extra
- ../../mig-tools
- ../../tools/mig-fast-logger
2 changes: 2 additions & 0 deletions mig-tools/.gitignore
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
.stack-work/
*~
30 changes: 30 additions & 0 deletions mig-tools/LICENSE
Original file line number Diff line number Diff line change
@@ -0,0 +1,30 @@
Copyright Author name here (c) 2023

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 Author name here 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.
1 change: 1 addition & 0 deletions mig-tools/README.md
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
# mig-tools
3 changes: 3 additions & 0 deletions mig-tools/Setup.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,3 @@
import Distribution.Simple

main = defaultMain
82 changes: 82 additions & 0 deletions mig-tools/mig-tools.cabal
Original file line number Diff line number Diff line change
@@ -0,0 +1,82 @@
cabal-version: 2.2

-- This file has been generated from package.yaml by hpack version 0.35.2.
--
-- see: https://github.com/sol/hpack

name: mig-tools
version: 0.1.0.0
description: Please see the README on GitHub at <https://github.com/githubuser/mig-tools#readme>
homepage: https://github.com/githubuser/mig-tools#readme
bug-reports: https://github.com/githubuser/mig-tools/issues
author: Author name here
maintainer: [email protected]
copyright: 2023 Author name here
license: BSD-3-Clause
license-file: LICENSE
build-type: Simple
extra-source-files:
README.md

source-repository head
type: git
location: https://github.com/githubuser/mig-tools

library
exposed-modules:
Mig.Tool.Base
Mig.Tool.Db
Mig.Tool.Log
other-modules:
Paths_mig_tools
autogen-modules:
Paths_mig_tools
hs-source-dirs:
src
default-extensions:
OverloadedStrings
OverloadedRecordDot
DuplicateRecordFields
LambdaCase
DerivingStrategies
StrictData
AllowAmbiguousTypes
DeriveAnyClass
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
build-depends:
aeson
, base >=4.7 && <5
, bytestring
, mtl
, text
, time
default-language: GHC2021

test-suite mig-tools-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Paths_mig_tools
autogen-modules:
Paths_mig_tools
hs-source-dirs:
test
default-extensions:
OverloadedStrings
OverloadedRecordDot
DuplicateRecordFields
LambdaCase
DerivingStrategies
StrictData
AllowAmbiguousTypes
DeriveAnyClass
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
build-depends:
aeson
, base >=4.7 && <5
, bytestring
, mig-tools
, mtl
, text
, time
default-language: GHC2021
Loading
Loading