packages feed

cherry-core-alpha 0.3.0.0 → 0.4.0.0

raw patch · 22 files changed

+831/−87 lines, 22 filesdep +aesondep +jose-jwtdep +postgresql-libpq

Dependencies added: aeson, jose-jwt, postgresql-libpq, text

Files

cherry-core-alpha.cabal view
@@ -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,
src/Basics.hs view
@@ -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
src/Environment.hs view
@@ -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
src/File.hs view
@@ -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))
+ src/Internal/Basics.hs view
@@ -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
src/Internal/Task.hs view
@@ -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+
src/Internal/Utils.hs view
@@ -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
+ src/JWT.hs view
@@ -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+
src/Json/Decode.hs view
@@ -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
src/Json/Encode.hs view
@@ -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
src/Json/String.hs view
@@ -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#
src/Maybe.hs view
@@ -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
src/Parser.hs view
@@ -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#))
+ src/Postgres.hs view
@@ -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"
+ src/Postgres/Decoder.hs view
@@ -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+
src/Server.hs view
@@ -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
src/String.hs view
@@ -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
src/Task.hs view
@@ -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
src/Terminal.hs view
@@ -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 (..))
+ src/Time.hs view
@@ -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)
+ src/Token.hs view
@@ -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."++
src/Url/Parser.hs view
@@ -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