diff --git a/cherry-core-alpha.cabal b/cherry-core-alpha.cabal --- a/cherry-core-alpha.cabal +++ b/cherry-core-alpha.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: cherry-core-alpha -version: 0.3.0.0 +version: 0.4.0.0 synopsis: The core library for Cherry Haskell. description: The core library for Cherry Haskell, including a standard fuctions, server, and json parsing. license: BSD3 @@ -30,9 +30,12 @@ Interop, Json.Decode, Json.Encode, + JWT, Http, List, Maybe, + Postgres, + Postgres.Decoder, Result, Set, Server, @@ -43,8 +46,11 @@ Url.Parser.Query, Task, Terminal, + Token, + Time, Tuple other-modules: + Internal.Basics, Internal.Shortcut, Internal.Task, Internal.Utils, @@ -69,11 +75,13 @@ build-depends: async >=2.2 && <2.3, base >=4.12 && <4.13, + aeson, binary, bytestring, containers >=0.6 && <0.7, directory, ghc-prim, + jose-jwt, base64-bytestring, wai-middleware-static, wai-extra, @@ -84,11 +92,13 @@ http-client-tls, http-types, mtl, + postgresql-libpq, safe-exceptions, case-insensitive, scientific, stm, text-utf8 >=1.2 && <1.3, + text, time, unix, utf8-string, diff --git a/src/Basics.hs b/src/Basics.hs --- a/src/Basics.hs +++ b/src/Basics.hs @@ -13,7 +13,7 @@ module Basics ( -- * Math - Int, Float, (+), (-), (*), (/), (//), (^) + Internal.Basics.Int, Internal.Basics.Float, (+), (-), (*), (/), (//), (^) -- * Int to Float / Float to Int , toFloat, round, floor, ceiling, truncate @@ -47,6 +47,8 @@ import qualified Prelude import qualified List import qualified String +import qualified Internal.Basics +import Internal.Basics -- INFIX OPERATORS @@ -67,44 +69,6 @@ -- MATHEMATICS - - -{-| An `Int` is a whole number. Valid syntax for integers includes: - - > 0 - > 42 - > 9000 - > 0xFF -- 255 in hexadecimal - > 0x000A -- 10 in hexadecimal - -Historical Note: The name `Int` comes from the term [integer](https://en.wikipedia.org/wiki/Integer). It appears -that the `int` abbreviation was introduced in [ALGOL 68](https://en.wikipedia.org/wiki/ALGOL_68), shortening it -from `integer` in [ALGOL 60](https://en.wikipedia.org/wiki/ALGOL_60). Today, almost all programming languages use -this abbreviation. - --} -type Int = Prelude.Int - - -{-| A `Float` is a [floating-point number](https://en.wikipedia.org/wiki/Floating-point_arithmetic). Valid syntax for floats includes: - - > 0 - > 42 - > 3.14 - > 0.1234 - > 6.022e23 -- == (6.022 * 10^23) - > 6.022e+23 -- == (6.022 * 10^23) - > 1.602e−19 -- == (1.602 * 10^-19) - > 1e3 -- == (1 * 10^3) == 1000 - -Historical Note: The particular details of floats (e.g. `NaN`) are -specified by [IEEE 754](https://en.wikipedia.org/wiki/IEEE_754) which is literally hard-coded into almost all -CPUs in the world. That means if you think `NaN` is weird, you must -successfully overtake Intel and AMD with a chip that is not backwards -compatible with any widely-used assembly language. - --} -type Float = Prelude.Double diff --git a/src/Environment.hs b/src/Environment.hs --- a/src/Environment.hs +++ b/src/Environment.hs @@ -1,4 +1,4 @@ -module Environment (variable) where +module Environment (optional, required) where import qualified System.Environment import qualified Data.ByteString as ByteString @@ -14,8 +14,19 @@ {-| -} -variable :: String -> Task String String -variable name = +optional :: String -> Task String (Maybe String) +optional name = + Interop.fromResult <| do + var <- System.Environment.lookupEnv (String.toList name) + Prelude.return <| case var of + Prelude.Nothing -> Ok Nothing + Prelude.Just value -> Ok (Just (String.fromList value)) + + + +{-| -} +required :: String -> Task String String +required name = Interop.fromResult <| do var <- System.Environment.lookupEnv (String.toList name) Prelude.return <| case var of diff --git a/src/File.hs b/src/File.hs --- a/src/File.hs +++ b/src/File.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PackageImports #-} {-| @@ -12,13 +13,13 @@ -} -module File (Path, read, write, doesExist) where +module File (Path, read, write, doesExist, list) where import qualified List import qualified String import qualified Internal.Task as Task import qualified Internal.Utils as U -import qualified Data.Text.IO as IO +import qualified "text-utf8" Data.Text.IO as IO import qualified System.Directory as Directory import Prelude (return, getContents) import Basics @@ -33,6 +34,7 @@ import Char (Char) +{-| -} type Path = String @@ -61,3 +63,11 @@ Task.Task <| do contents <- IO.readFile (String.toList filename) return (Ok (String.fromTextUtf8 contents)) + + +{-| -} +list :: Path -> Task x (List Path) +list path = + Task.Task <| do + files <- Directory.listDirectory (String.toList path) + return (Ok (List.map String.fromList files)) diff --git a/src/Internal/Basics.hs b/src/Internal/Basics.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Basics.hs @@ -0,0 +1,41 @@ +module Internal.Basics where + +import qualified Prelude + + +{-| An `Int` is a whole number. Valid syntax for integers includes: + + > 0 + > 42 + > 9000 + > 0xFF -- 255 in hexadecimal + > 0x000A -- 10 in hexadecimal + +Historical Note: The name `Int` comes from the term [integer](https://en.wikipedia.org/wiki/Integer). It appears +that the `int` abbreviation was introduced in [ALGOL 68](https://en.wikipedia.org/wiki/ALGOL_68), shortening it +from `integer` in [ALGOL 60](https://en.wikipedia.org/wiki/ALGOL_60). Today, almost all programming languages use +this abbreviation. + +-} +type Int = Prelude.Int + + +{-| A `Float` is a [floating-point number](https://en.wikipedia.org/wiki/Floating-point_arithmetic). Valid syntax for floats includes: + + > 0 + > 42 + > 3.14 + > 0.1234 + > 6.022e23 -- == (6.022 * 10^23) + > 6.022e+23 -- == (6.022 * 10^23) + > 1.602e−19 -- == (1.602 * 10^-19) + > 1e3 -- == (1 * 10^3) == 1000 + +Historical Note: The particular details of floats (e.g. `NaN`) are +specified by [IEEE 754](https://en.wikipedia.org/wiki/IEEE_754) which is literally hard-coded into almost all +CPUs in the world. That means if you think `NaN` is weird, you must +successfully overtake Intel and AMD with a chip that is not backwards +compatible with any widely-used assembly language. + +-} +type Float = Prelude.Double diff --git a/src/Internal/Task.hs b/src/Internal/Task.hs --- a/src/Internal/Task.hs +++ b/src/Internal/Task.hs @@ -2,13 +2,14 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PackageImports #-} module Internal.Task where import qualified Prelude as P -import qualified Data.Text +import qualified "text-utf8" Data.Text +import qualified "text-utf8" Data.Text.Encoding import qualified Control.Exception.Safe as Control -import qualified Data.Text.Encoding import qualified Data.ByteString.Lazy as ByteString import qualified GHC.Stack as Stack import qualified Internal.Shortcut as Shortcut @@ -189,3 +190,12 @@ parallel :: List (Task x a) -> Task x (List a) parallel tasks = Task <| Shortcut.map P.sequence (Async.forConcurrently tasks toIO) + + +{-| -} +fromResult :: Result x a -> Task x a +fromResult result = + case result of + Ok a -> succeed a + Err x -> fail x + diff --git a/src/Internal/Utils.hs b/src/Internal/Utils.hs --- a/src/Internal/Utils.hs +++ b/src/Internal/Utils.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE PackageImports #-} + module Internal.Utils where import qualified String import qualified List import qualified Dict -import qualified Data.Text +import qualified "text-utf8" Data.Text import qualified GHC.Stack as Stack import qualified System.IO import qualified Control.Concurrent.MVar as MVar diff --git a/src/JWT.hs b/src/JWT.hs new file mode 100644 --- /dev/null +++ b/src/JWT.hs @@ -0,0 +1,58 @@ +module JWT (init, Env, expirationSecs, jwks) where + +import Cherry.Prelude +import qualified Data.ByteString as ByteString +import qualified Jose.Jwk +import qualified Json.Decode as D +import qualified Interop +import qualified Task +import qualified Environment +import qualified Result +import qualified String +import qualified Maybe +import qualified File +import qualified Data.Aeson as Aeson + + +{-| -} +data Env = Env + { expirationSecs :: Int + , jwks :: List Jose.Jwk.Jwk + } + + +{-| -} +init :: Task String Env +init = + Task.map2 Env + acquireExpirationSecs + acquireJwks + + +acquireJwks :: Task String (List Jose.Jwk.Jwk) +acquireJwks = do + path <- Environment.optional "JWK_PATH" + contents <- File.read (Maybe.withDefault "secrets/jwk.sig" path) + case decode (String.toByteString contents) of + Ok jwks -> Task.succeed jwks + Err err -> Task.fail err + + +decode :: ByteString.ByteString -> Result.Result String (List Jose.Jwk.Jwk) +decode file = + Aeson.eitherDecodeStrict file + |> Result.fromEither + |> Result.mapError (\msg -> "Could not decode JWK file: " ++ String.fromList msg) + + +acquireExpirationSecs :: Task String Int +acquireExpirationSecs = do + string <- Environment.optional "JWT_EXPIRATION_SECS" + let secs = Maybe.withDefault defaultExpirationSecs (Maybe.andThen String.toInt string) + Task.succeed secs + + +defaultExpirationSecs :: Int +defaultExpirationSecs = + 2 * 60 * 60 + diff --git a/src/Json/Decode.hs b/src/Json/Decode.hs --- a/src/Json/Decode.hs +++ b/src/Json/Decode.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-} {-# LANGUAGE BangPatterns, Rank2Types, MagicHash, OverloadedStrings, UnboxedTuples, TypeSynonymInstances #-} +{-# LANGUAGE PackageImports #-} {-| @@ -48,27 +49,28 @@ where -import Prelude hiding ((++), Float, String, maybe, map, fail, null) import qualified Data.List as List hiding (map) -import qualified Data.Maybe as Maybe -import qualified Data.Text.IO +import qualified "text-utf8" Data.Text.IO +import qualified Parser as P +import qualified String +import qualified Dict +import qualified Json.String as JS +import qualified Internal.Task import GHC.Prim (ByteArray#) import GHC.Word (Word8) import Basics ((++), Float, (<|)) import Dict (Dict) -import qualified Dict -import qualified Json.String as JS import List (List) import Parser (Pos, End, Row, Col) -import qualified Parser as P import Result (Result(..)) import String (String) -import qualified String +import Maybe (Maybe(..)) import Task (Task) -import qualified Internal.Task +import Prelude hiding ((++), Float, String, Maybe(..), maybe, map, fail, null) + -- RUNNERS @@ -375,20 +377,20 @@ > fromString (nullable int) "true" == Err .. -} -nullable :: Decoder a -> Decoder (Maybe.Maybe a) +nullable :: Decoder a -> Decoder (Maybe a) nullable decoder = oneOf - [ fmap Maybe.Just decoder + [ fmap Just decoder , null_ ] -null_ :: Decoder (Maybe.Maybe a) +null_ :: Decoder (Maybe a) null_ = Decoder $ \ast ok err -> case ast of NULL -> - ok Maybe.Nothing + ok Nothing _ -> err (Expecting TNull) @@ -434,11 +436,11 @@ Point is, `maybe` will make exactly what it contains conditional. For optional fields, this means you probably want it *outside* a use of `field` or `at`. -} -maybe :: Decoder a -> Decoder (Maybe.Maybe a) +maybe :: Decoder a -> Decoder (Maybe a) maybe decoder_ = oneOf - [ fmap Maybe.Just decoder_ - , return Maybe.Nothing + [ fmap Just decoder_ + , return Nothing ] @@ -634,25 +636,25 @@ case ast of Object kvs -> case findField key kvs of - Maybe.Just value -> + Just value -> let err' prob = err (Field key prob) in decodeA value ok err' - Maybe.Nothing -> + Nothing -> err (Expecting (TObjectWith key)) _ -> err (Expecting TObject) -findField :: String -> [( String, AST )] -> Maybe.Maybe AST +findField :: String -> [( String, AST )] -> Maybe AST findField key pairs = case pairs of [] -> - Maybe.Nothing + Nothing (bts, value) : remainingPairs -> if key == bts diff --git a/src/Json/Encode.hs b/src/Json/Encode.hs --- a/src/Json/Encode.hs +++ b/src/Json/Encode.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, PackageImports #-} {-| @@ -33,11 +33,10 @@ import Data.ByteString.Builder.Prim ((>$<), (>*<)) import qualified Data.ByteString.Builder as B import qualified Data.Char as Char -import qualified Data.Text.Encoding as TE +import qualified "text-utf8" Data.Text.Encoding as TE import Data.Monoid ((<>)) import Prelude hiding (String, Float, null) import Data.Word (Word8) - import Basics (Float) import qualified Dict import qualified List diff --git a/src/Json/String.hs b/src/Json/String.hs --- a/src/Json/String.hs +++ b/src/Json/String.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} -{-# LANGUAGE MagicHash, UnboxedTuples #-} +{-# LANGUAGE MagicHash, UnboxedTuples, PackageImports #-} module Json.String ( Chunk(..) , toTextUtf8 @@ -9,8 +9,8 @@ import Prelude (($), (+), (<), (=<<), fromIntegral, map, otherwise, sum) import Data.Bits ((.&.), shiftR) -import qualified Data.Text.Internal as T -import qualified Data.Text.Array as T (Array(Array)) +import qualified "text-utf8" Data.Text.Internal as T +import qualified "text-utf8" Data.Text.Array as T (Array(Array)) import GHC.Exts ( Int(I#) , ByteArray# diff --git a/src/Maybe.hs b/src/Maybe.hs --- a/src/Maybe.hs +++ b/src/Maybe.hs @@ -21,6 +21,9 @@ -- * Chaining Maybes , andThen + + -- * From Haskell types + , fromHMaybe ) where @@ -174,3 +177,11 @@ andThen :: (a -> Maybe b) -> Maybe a -> Maybe b andThen = Shortcut.andThen + + +{-| -} +fromHMaybe :: Prelude.Maybe a -> Maybe a +fromHMaybe maybe = + case maybe of + Prelude.Just a -> Just a + Prelude.Nothing -> Nothing diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-} {-# LANGUAGE BangPatterns, MagicHash, Rank2Types, UnboxedTuples #-} +{-# LANGUAGE PackageImports #-} + module Parser ( fromString , Parser(..), State(..), Pos, End, Row, Col @@ -18,8 +20,8 @@ import qualified Data.Char as Char -import qualified Data.Text.Internal as T -import qualified Data.Text.Array as T +import qualified "text-utf8" Data.Text.Internal as T +import qualified "text-utf8" Data.Text.Array as T import GHC.Exts (Char(C#), Int#, (+#), (-#), chr#, uncheckedIShiftL#, word2Int#) import GHC.Prim (ByteArray#, indexWord8Array#) import GHC.Types (Int(I#)) diff --git a/src/Postgres.hs b/src/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Postgres.hs @@ -0,0 +1,120 @@ +module Postgres (Connection, connect, execute, executeOne, Variable, int, text, bool, real, enum, null) where + +import qualified Control.Exception +import qualified Database.PostgreSQL.LibPQ as PG +import qualified Data.Either +import qualified Data.Maybe +import qualified Maybe +import qualified String +import qualified List +import qualified Result +import qualified Task +import qualified Terminal +import qualified Internal.Task +import qualified Internal.Utils as U +import qualified Internal.Shortcut as IO +import qualified Postgres.Decoder as Decoder +import Cherry.Prelude + + +{-| + +TODO: + - async connect + +-} + + +{-| -} +newtype Connection + = Connection PG.Connection + + +{-| -} +connect :: String -> Task String Connection +connect details = + PG.connectdb (String.toByteString details) + |> IO.map (Result.Ok << Connection) + |> Internal.Task.Task + + +{-| -} +execute :: Connection -> String -> List Variable -> Decoder.Table a -> Task String (List a) +execute (Connection connection) query variables decoder = do + let replaceOne ( i, v ) = String.replace ("$" ++ String.fromInt (i + 1)) (toValue v) + let final = List.foldl replaceOne query (List.indexedMap (,) variables) + Terminal.write (U.blue ++ "Executed query: " ++ U.reset ++ final) + result <- Internal.Task.Task <| do + PG.exec connection (String.toByteString final) + |> IO.map (Maybe.fromHMaybe >> Result.fromMaybe "Bad query.") + Decoder.run decoder result + + +{-| -} +executeOne :: Connection -> String -> List Variable -> Decoder.Table a -> Task String a +executeOne connection query variables decoder = + let getOne all = + case all of + [] -> Task.fail "Query rendered no results!" + first : [] -> Task.succeed first + rest -> Task.fail "Query rendered more than one results!" + in do + rows <- execute connection query variables decoder + getOne rows + + +{-| -} +data Variable + = Int Int + | Text String + | Boolean Bool + | Real Float + | Enum String String + | NULL + + +{-| -} +int :: Int -> Variable +int = + Int + + +{-| -} +text :: String -> Variable +text = + Text + + +{-| -} +bool :: Bool -> Variable +bool = + Boolean + + +{-| -} +real :: Float -> Variable +real = + Real + + +{-| -} +enum :: String -> String -> Variable +enum = + Enum + + +{-| -} +null :: Variable +null = + NULL + + +toValue :: Variable -> String +toValue variable = + case variable of + Int int -> String.fromInt int + Text string -> "\'" ++ string ++ "\'" + Boolean bool -> if bool then "TRUE" else "FALSE" + Real float -> String.fromFloat float + Enum _ value -> "\'" ++ value ++ "\'" + NULL -> "NULL" diff --git a/src/Postgres/Decoder.hs b/src/Postgres/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Postgres/Decoder.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Postgres.Decoder + ( run + , Table, table, table2, table3, table4, table5, table6 + , Column, column + , Value, map, nullable, string, int, bool + ) where + +import qualified Database.PostgreSQL.LibPQ as PG +import qualified Prelude +import qualified Maybe +import qualified List +import qualified Debug +import qualified Dict +import qualified String +import qualified Task +import qualified Result +import qualified Http +import qualified Internal.Task +import qualified Internal.Shortcut as Shortcut +import qualified Prelude as P +import Cherry.Prelude + + +{-| -} +newtype Table a + = Table (PG.Result -> Task String (List a)) + + +{-| -} +newtype Column a + = Column (PG.Result -> PG.Row -> Task String a) + + +{-| -} +newtype Value a + = Value (Maybe String -> Result String a) + + + +-- RUN + + +{-| -} +run :: Table a -> PG.Result -> Task String (List a) +run (Table decoder) result = + decoder result + + + +-- TABLES + + +{-| -} +table :: (a -> b) -> Column a -> Table b +table func (Column column1) = + Table <| \result -> + readRows result <| \row -> + Task.map func + (column1 result row) + + +{-| -} +table2 :: (a -> b -> c) -> Column a -> Column b -> Table c +table2 func (Column column1) (Column column2) = + Table <| \result -> + readRows result <| \row -> + Task.map2 func + (column1 result row) + (column2 result row) + + +{-| -} +table3 :: (a -> b -> c -> d) -> Column a -> Column b -> Column c -> Table d +table3 func (Column column1) (Column column2) (Column column3) = + Table <| \result -> + readRows result <| \row -> + Task.map3 func + (column1 result row) + (column2 result row) + (column3 result row) + + +{-| -} +table4 :: (a -> b -> c -> d -> e) -> Column a -> Column b -> Column c -> Column d -> Table e +table4 func (Column column1) (Column column2) (Column column3) (Column column4) = + Table <| \result -> + readRows result <| \row -> + Task.map4 func + (column1 result row) + (column2 result row) + (column3 result row) + (column4 result row) + + +{-| -} +table5 :: (a -> b -> c -> d -> e -> f) -> Column a -> Column b -> Column c -> Column d -> Column e -> Table f +table5 func (Column column1) (Column column2) (Column column3) (Column column4) (Column column5) = + Table <| \result -> + readRows result <| \row -> + Task.map5 func + (column1 result row) + (column2 result row) + (column3 result row) + (column4 result row) + (column5 result row) + + +{-| -} +table6 :: (a -> b -> c -> d -> e -> f -> g) -> Column a -> Column b -> Column c -> Column d -> Column e -> Column f -> Table g +table6 func (Column column1) (Column column2) (Column column3) (Column column4) (Column column5) (Column column6) = + Table <| \result -> + readRows result <| \row -> + Task.map6 func + (column1 result row) + (column2 result row) + (column3 result row) + (column4 result row) + (column5 result row) + (column6 result row) + + + +-- COLUMN + + +{-| -} +column :: String -> Value a -> Column a +column name (Value decoder) = + Column <| \result row -> + columnNumber result name + |> Task.andThen (getValue result row) + |> Task.andThen (decoder >> Task.fromResult) + + + +-- VALUE + + +{-| -} +map :: (a -> b) -> Value a -> Value b +map f (Value decoder) = + Value <| \string -> + Result.map f (decoder string) + + +{-| -} +nullable :: Value a -> Value (Maybe a) +nullable (Value decoder) = + Value <| \maybeValue -> + case maybeValue of + Nothing -> Result.Ok Nothing + Just _ -> Result.map Just (decoder maybeValue) + + +{-| -} +string :: Value String +string = + Value <| \maybeString -> + withNotNull maybeString <| \string -> + Result.Ok string + + +{-| -} +int :: Value Int +int = + Value <| \maybeString -> + withNotNull maybeString <| \string -> + String.toInt string + |> Result.fromMaybe "Value is not an int." + + +{-| -} +bool :: Value Bool +bool = + Value <| \maybeString -> + withNotNull maybeString <| \string -> + case String.toUpper string of + "T" -> Result.Ok True + "F" -> Result.Ok False + _ -> Result.Err "Value is not an boolean." + + + +-- HELPERS + + +withNotNull :: Maybe String -> (String -> Result String a) -> Result String a +withNotNull maybeString func = + case maybeString of + Nothing -> + Result.Err "Illegal value: NULL" + + Just string -> + func string + + +readRows :: PG.Result -> (PG.Row -> Task String a) -> Task String (List a) +readRows result decode = + let read done index total = + if PG.toRow index == total then + Task.sequence done + else + read (decode (PG.toRow index) : done) (index + 1) total + in + Task.andThen (read [] 0) (numberOfRows result) + + +numberOfRows :: PG.Result -> Task String PG.Row +numberOfRows result = + PG.ntuples result + |> Shortcut.map Result.Ok + |> Internal.Task.Task + + +columnNumber :: PG.Result -> String -> Task String PG.Column +columnNumber result name = + PG.fnumber result (String.toByteString name) + |> Shortcut.map (Maybe.fromHMaybe >> Result.fromMaybe "Could not find column.") + |> Internal.Task.Task + + +getValue :: PG.Result -> PG.Row -> PG.Column -> Task String (Maybe String) +getValue result row column = + Internal.Task.Task <| do + value <- PG.getvalue result row column + value + |> Maybe.fromHMaybe + |> Maybe.map String.fromByteString + |> Result.Ok + |> P.return + diff --git a/src/Server.hs b/src/Server.hs --- a/src/Server.hs +++ b/src/Server.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + {-| Module : Server @@ -9,7 +11,7 @@ -} -module Server (listen, get, post, text, json, file, body) where +module Server (Route, listen, get, post, text, json, file, body, getLogin, getToken, findHeader) where import qualified Control.Exception.Safe as Control import qualified Data.ByteString as B @@ -18,10 +20,10 @@ import qualified Data.Either as Either import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Base64 as Base64 -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Encoding as Encoding -import qualified Data.Text.Encoding.Error as Encoding +import qualified "text-utf8" Data.Text as T +import qualified "text-utf8" Data.Text.Lazy as TL +import qualified "text-utf8" Data.Text.Encoding as Encoding +import qualified "text-utf8" Data.Text.Encoding.Error as Encoding import qualified Data.Time.Clock.POSIX as POSIX import qualified Data.CaseInsensitive as CI import qualified Network.Wai as Wai @@ -152,6 +154,74 @@ in getChunks [] |> Task.andThen decode + + + +-- HELPERS / AUTH + + +{-| -} +getToken :: Http.Request -> Result String String +getToken request = + findHeader "Authorization" request + |> Result.map dropBasic + |> Result.andThen decodeBase64 + + +{-| -} +getLogin :: Http.Request -> Result String ( String, String ) +getLogin request = + findHeader "Authorization" request + |> Result.map dropBasic + |> Result.andThen decodeBase64 + |> Result.andThen textToAuthForm + + +dropBasic :: String -> String +dropBasic = + String.dropLeft 6 + + +decodeBase64 :: String -> Result String String +decodeBase64 value = + value + |> String.toByteString + |> Base64.decode + |> Result.fromEither + |> Result.mapError String.fromList + |> Result.map String.fromByteString + + +textToAuthForm :: String -> Result String ( String, String ) +textToAuthForm text = + case String.split ":" text of + [ email, password ] -> Ok ( email, password ) + _ -> Err ("Bad value: " ++ text) + + + + +-- HELPERS / HEADER + + +{-| -} +findHeader :: CI.CI B.ByteString -> Http.Request -> Result String String +findHeader name request = + let isCorrect ( header, value ) = header == name + getValue ( header, value ) = value + nameAsError = String.fromByteString (CI.original name) + in + findFirst isCorrect (Wai.requestHeaders request) + |> Maybe.map getValue + |> Result.fromMaybe ("Request is missing \"" ++ nameAsError ++ "\" header.") + |> Result.map String.fromByteString + + +findFirst :: (a -> Bool) -> List a -> Maybe a +findFirst isCorrect all = + case all of + a : rest -> if isCorrect a then Just a else findFirst isCorrect rest + [] -> Nothing diff --git a/src/String.hs b/src/String.hs --- a/src/String.hs +++ b/src/String.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PackageImports #-} {-| @@ -48,7 +49,8 @@ ) where -import Prelude (Bool, Float, Int, (+), (<), Show, show) +import Prelude (Bool, (+), (<), Show, show) +import Internal.Basics import Char (Char) import List (List) import Maybe (Maybe(..)) @@ -57,9 +59,9 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL import qualified Data.String as HS -import qualified Data.Text as HT -import qualified Data.Text.Encoding as HTE -import qualified Data.Text.Internal.Search as HTIS +import qualified "text-utf8" Data.Text as HT +import qualified "text-utf8" Data.Text.Encoding as HTE +import qualified "text-utf8" Data.Text.Internal.Search as HTIS import qualified Data.Maybe as HM import qualified Text.Read as HTR import qualified List as List diff --git a/src/Task.hs b/src/Task.hs --- a/src/Task.hs +++ b/src/Task.hs @@ -17,7 +17,7 @@ ( Task, Task.perform, Task.attempt -- * Chains - , andThen, Task.succeed, Task.fail, Task.sequence, Task.parallel + , andThen, Task.succeed, Task.fail, Task.fromResult, Task.sequence, Task.parallel -- * Maps , map, map2, map3, map4, map5, map6 diff --git a/src/Terminal.hs b/src/Terminal.hs --- a/src/Terminal.hs +++ b/src/Terminal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PackageImports #-} {-| @@ -18,7 +19,7 @@ import qualified String import qualified Internal.Task as Task import qualified Internal.Utils as U -import qualified Data.Text.IO as IO +import qualified "text-utf8" Data.Text.IO as IO import Prelude (return, getContents) import Basics import Maybe (Maybe (..)) diff --git a/src/Time.hs b/src/Time.hs new file mode 100644 --- /dev/null +++ b/src/Time.hs @@ -0,0 +1,19 @@ +module Time (POSIX, now) where + + +import qualified Data.Time.Clock.POSIX as POSIX +import qualified Internal.Task as Task +import qualified Prelude as P +import Cherry.Prelude + + +type POSIX + = POSIX.POSIXTime + + +{-| -} +now :: Task String POSIX +now = + Task.Task <| do + time <- POSIX.getPOSIXTime + P.return (Ok time) diff --git a/src/Token.hs b/src/Token.hs new file mode 100644 --- /dev/null +++ b/src/Token.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE PackageImports #-} + +module Token (Token, generate, resolve) where + + +import qualified Prelude as P +import qualified Data.Either as Either +import qualified Data.Maybe as HMaybe +import qualified Data.Aeson.Types as Json +import qualified Data.Aeson as Aeson +import qualified "text" Data.Text as T +import qualified "text" Data.Text.Lazy as TL +import qualified "text" Data.Text.Encoding as Encoding +import qualified "text" Data.Text.Encoding.Error as Encoding +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.Time.Clock.POSIX as POSIX +import qualified Data.Time.Clock as Clock +import qualified Data.Maybe as HMaybe +import qualified Jose.Jwt as Jwt +import qualified Jose.Jwa as Jwa +import qualified Control.Monad.Except as Except +import qualified Text.Read +import qualified Internal.Shortcut as Shortcut +import qualified Interop +import qualified JWT +import qualified Result +import qualified Task +import qualified Internal.Task +import qualified Maybe +import qualified String +import qualified Time +import Cherry.Prelude + + +{-| -} +type Token = + String + + + +-- GENERATE + + +{-| -} +generate :: JWT.Env -> String -> Task String Token +generate env userId = do + now <- Time.now + payload <- encodeJwt env (claims env userId now) + Task.succeed (String.fromByteString payload) + + +claims :: JWT.Env -> String -> Time.POSIX -> Jwt.Payload +claims env userId now = + Jwt.JwtClaims + { Jwt.jwtIss = HMaybe.Nothing + , Jwt.jwtSub = HMaybe.Just (T.pack (String.toList userId)) + , Jwt.jwtAud = HMaybe.Nothing + , Jwt.jwtExp = HMaybe.Just (Jwt.IntDate (expirationTime env now)) + , Jwt.jwtNbf = HMaybe.Nothing + , Jwt.jwtIat = HMaybe.Nothing + , Jwt.jwtJti = HMaybe.Nothing + } + |> Aeson.encode + |> BL.toStrict + |> Jwt.Claims + + +expirationTime :: JWT.Env -> Time.POSIX -> Time.POSIX +expirationTime env now = + now + P.fromIntegral (JWT.expirationSecs env) + + +encodeJwt :: JWT.Env -> Jwt.Payload -> Task String B.ByteString +encodeJwt env payload = + let fromEither either = + case either of + Either.Right (Jwt.Jwt encoded) -> Result.Ok encoded + Either.Left err -> Result.Err (toErrorMsg err) + in + Jwt.encode (JWT.jwks env) (Jwt.JwsEncoding Jwa.RS256) payload + |> Shortcut.map fromEither + |> Internal.Task.Task + + + +-- RESOLVE + + +{-| -} +resolve :: JWT.Env -> Token -> Task String String +resolve env token = + let check :: Time.POSIX -> B.ByteString -> Task String String + check now token_ = + decodeClaims token_ + |> Task.andThen (isExpired now) + |> Task.andThen parseClaims + in do + now <- Time.now + token_ <- decodeToken env token + check now token_ + + +decodeToken :: JWT.Env -> Token -> Task String B.ByteString +decodeToken env token = + let utf8Token = String.toByteString token + settings = Jwt.JwsEncoding Jwa.RS256 + fromEither jwt = + case jwt of + Either.Right ( Jwt.Jws ( header, json ) ) -> Ok json + Either.Left err -> Err (toErrorMsg err) + in + Jwt.decode (JWT.jwks env) (HMaybe.Just settings) utf8Token + |> Shortcut.map fromEither + |> Internal.Task.Task + + +decodeClaims :: B.ByteString -> Task String Jwt.JwtClaims +decodeClaims claims = + claims + |> BL.fromStrict + |> Aeson.eitherDecode + |> Result.fromEither + |> Result.mapError String.fromList + |> Task.fromResult + + +isExpired :: Time.POSIX -> Jwt.JwtClaims -> Task String Jwt.JwtClaims +isExpired now claims = + if expiration now claims < now then + Task.fail "Token is expired." + else + Task.succeed claims + + +expiration :: Time.POSIX -> Jwt.JwtClaims -> Time.POSIX +expiration now claims = + let jwtExpiration = Maybe.fromHMaybe (Jwt.jwtExp claims) + (Jwt.IntDate date) = Maybe.withDefault (Jwt.IntDate now) jwtExpiration + in + date + + +parseClaims :: Jwt.JwtClaims -> Task String String +parseClaims claims = + claims + |> Jwt.jwtSub + |> Maybe.fromHMaybe + |> Maybe.map (String.fromByteString << Encoding.encodeUtf8) + |> Result.fromMaybe "Could not parse claims." + |> Task.fromResult + + + +-- SHARED + + +toErrorMsg :: Jwt.JwtError -> String +toErrorMsg error = + case error of -- TODO err type ? + Jwt.KeyError _ -> "No suitable key or wrong key type." + Jwt.BadAlgorithm _ -> "The supplied algorithm is invalid." + Jwt.BadDots _ -> "Wrong number of \".\" characters in the JWT." + Jwt.BadHeader _ -> "Header couldn't be decoded or contains bad data." + Jwt.BadClaims -> "Claims part couldn't be decoded or contains bad data." + Jwt.BadSignature -> "Signature is invalid." + Jwt.BadCrypto -> "A cryptographic operation failed." + Jwt.Base64Error _ -> "A base64 decoding error." + + diff --git a/src/Url/Parser.hs b/src/Url/Parser.hs --- a/src/Url/Parser.hs +++ b/src/Url/Parser.hs @@ -21,7 +21,7 @@ -} module Url.Parser - ( Parser, string, int, s + ( Parser, string, int, s, anything , (), map, oneOf, top, custom , (), query , parse @@ -94,6 +94,14 @@ int :: Parser (Int -> a) a int = custom "NUMBER" String.toInt + + + +{-| -} +anything :: Parser (List String -> a) a +anything = + Parser <| \state -> + [ State (unvisited state ++ visited state) [] (params state) (value state <| unvisited state) ] {-| Parse a segment of the path if it matches a given string. It is almost