Use ✓ instead of √

Use ✓ instead of √

module Test.Spec.Reporter (
  Entry(..),
  collapse,
  report
  ) where

import Debug.Trace
import Data.String
import Data.Array (map, concatMap)
import Data.Foldable
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Extras
import qualified Test.Spec as S
import Test.Spec.Console
import Test.Spec.Summary
import Test.Spec.Reporter.Summary

foreign import showAssertionError
  """
  function showAssertionError(err) {
    return err.message;
  }
  """ :: Error -> String

data Entry = Describe [S.Name]
           | It S.Name S.Result
           | Pending S.Name

instance eqEntry :: Eq Entry where
  (==) (Describe n1) (Describe n2) = n1 == n2
  (==) (It n1 S.Success) (It n2 S.Success) = n1 == n2
  (==) (It n1 (S.Failure e1)) (It n2 (S.Failure e2)) =
    n1 == n2 && (showAssertionError e1) == (showAssertionError e2)
  (==) (It n1 _) (It n2 _) = false
  (==) (Pending n1) (Pending n2) = n1 == n2
  (/=) e1 e2 = not (e1 == e2)

instance showEntry :: Show Entry where
  show (Describe names) = "Describe \"" ++ (joinWith " » " names) ++ "\""
  show (It name S.Success) = "It \"" ++ name ++ "\" Success"
  show (It name (S.Failure err)) = "It \"" ++ name ++ "\" (Failure \"" ++ showAssertionError err ++ "\")"
  show (Pending name) = "Pending \"" ++ name ++ "\""

printEntry :: forall r. Entry
           -> Eff (trace :: Trace | r) Unit
printEntry (It name S.Success) = do
  withAttrs [32] $ writeln $  "✓ " ++ name
printEntry (Pending name) = do
  withAttrs [33] $ writeln $  "~ " ++ name
printEntry (It name (S.Failure err)) = do
  withAttrs [31] $ writeln $ "✗ " ++ name ++ ":"
  trace ""
  withAttrs [31] $ writeln $ "  " ++ showAssertionError err
  trace ""
printEntry (Describe []) = return unit
printEntry (Describe [last]) =
  withAttrs [1, 35] $ writeln last
printEntry (Describe (name : names)) = do
  withAttrs [1] do
    write name
    write " » "
  printEntry $ Describe names

countDescribes :: [Entry] -> Number
countDescribes groups = foldl f 0 groups
  where f c (Describe _) = c + 1
        f c _ = c

collapse :: S.Group -> [Entry]
collapse (S.It name result) = [It name result]
collapse (S.Pending name) = [Pending name]
collapse (S.Describe name groups) =
  let sub = concatMap collapse groups
      prependName (Describe names) = Describe (name : names)
      prependName e = e
      c = countDescribes sub
  in if c == 0 then (Describe [name]) : sub
               else map prependName sub

report :: forall r. [S.Group] -> Eff (trace :: Trace | r) Unit
report groups = do
  writeln ""
  mapM_ printEntry $ concatMap collapse groups
  printSummary groups

module Test.Spec.Reporter (
  Entry(..),
  collapse,
  report
  ) where

import Debug.Trace
import Data.String
import Data.Array (map, concatMap)
import Data.Foldable
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Extras
import qualified Test.Spec as S
import Test.Spec.Console
import Test.Spec.Summary
import Test.Spec.Reporter.Summary

foreign import showAssertionError
  """
  function showAssertionError(err) {
    return err.message;
  }
  """ :: Error -> String

data Entry = Describe [S.Name]
           | It S.Name S.Result
           | Pending S.Name

instance eqEntry :: Eq Entry where
  (==) (Describe n1) (Describe n2) = n1 == n2
  (==) (It n1 S.Success) (It n2 S.Success) = n1 == n2
  (==) (It n1 (S.Failure e1)) (It n2 (S.Failure e2)) =
    n1 == n2 && (showAssertionError e1) == (showAssertionError e2)
  (==) (It n1 _) (It n2 _) = false
  (==) (Pending n1) (Pending n2) = n1 == n2
  (/=) e1 e2 = not (e1 == e2)

instance showEntry :: Show Entry where
  show (Describe names) = "Describe \"" ++ (joinWith " » " names) ++ "\""
  show (It name S.Success) = "It \"" ++ name ++ "\" Success"
  show (It name (S.Failure err)) = "It \"" ++ name ++ "\" (Failure \"" ++ showAssertionError err ++ "\")"
  show (Pending name) = "Pending \"" ++ name ++ "\""

printEntry :: forall r. Entry
           -> Eff (trace :: Trace | r) Unit
printEntry (It name S.Success) = do
  withAttrs [32] $ writeln $  "√ " ++ name
printEntry (Pending name) = do
  withAttrs [33] $ writeln $  "~ " ++ name
printEntry (It name (S.Failure err)) = do
  withAttrs [31] $ writeln $ "✗ " ++ name ++ ":"
  trace ""
  withAttrs [31] $ writeln $ "  " ++ showAssertionError err
  trace ""
printEntry (Describe []) = return unit
printEntry (Describe [last]) =
  withAttrs [1, 35] $ writeln last
printEntry (Describe (name : names)) = do
  withAttrs [1] do
    write name
    write " » "
  printEntry $ Describe names

countDescribes :: [Entry] -> Number
countDescribes groups = foldl f 0 groups
  where f c (Describe _) = c + 1
        f c _ = c

collapse :: S.Group -> [Entry]
collapse (S.It name result) = [It name result]
collapse (S.Pending name) = [Pending name]
collapse (S.Describe name groups) =
  let sub = concatMap collapse groups
      prependName (Describe names) = Describe (name : names)
      prependName e = e
      c = countDescribes sub
  in if c == 0 then (Describe [name]) : sub
               else map prependName sub

report :: forall r. [S.Group] -> Eff (trace :: Trace | r) Unit
report groups = do
  writeln ""
  mapM_ printEntry $ concatMap collapse groups
  printSummary groups


Removed accidental lines from comment

Removed accidental lines from comment

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Utils.Aff where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Rec.Class (Step(..), tailRecM)

-- | Loop until a condition becomes `true`.
-- |
-- | `untilE b` is an effectful computation which repeatedly runs the effectful
-- | computation `b`, until its return value is `true`.
untilA ∷ ∀ eff. Aff eff Boolean → Aff eff Unit
untilA aff =
  tailRecM go unit
  where
  go = const $ (if _ then pure (Done unit) else pure (Loop unit)) =<< aff

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

throw ∷ ∀ a eff. String → Aff eff a
throw = throwError <<< Exception.error

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Utils.Aff where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Rec.Class (Step(..), tailRecM)

-- | Loop until a condition becomes `true`.
-- |
-- | `untilE b` is an effectful computation which repeatedly runs the effectful
-- | computation `b`, until its return value is `true`.
untilA ∷ ∀ eff. Aff eff Boolean → Aff eff Unit
untilA aff =
  tailRecM go unit
  where
  go = const $ (if _ then pure (Done unit) else pure (Loop unit)) =<< aff


Render IRUnion as enum in Swift

Render IRUnion as enum in Swift

Original commit ad513d9157692eb59e5618f29f0d5888043df5e6

module Swift
    ( renderSwiftClass
    ) where

import Prelude

import Doc
import IR

import Data.Foldable (for_, intercalate)
import Data.Function (on)

import Data.List as L
import Data.List.NonEmpty as NE

import Data.Map as M

import Data.Set as S
import Data.Tuple (Tuple(..))

renderSwiftClass :: IRClassData -> Doc Unit
renderSwiftClass { name, properties } = do
    line $ words ["struct", name]
    line "{"
    indent do
        let props = properties # M.toUnfoldable <#> \(Tuple name typ) -> { name, typ }
        let propGroups = L.groupBy (eq `on` _.typ) props
        for_ propGroups renderPropGroup
    line "}"

    blank

    for_ (M.values properties) renderUnions

renderPropGroup :: NE.NonEmptyList { name :: String, typ :: IRType} -> Doc Unit
renderPropGroup props = line do
    let names = intercalate ", " (_.name <$> props)
    words ["let", names <> ":"]
    string " "

    let { typ } = NE.head props
    string $ renderType typ

renderType :: IRType -> String
renderType = case _ of
    IRNothing -> "Any"
    IRNull -> "Any"
    IRInteger -> "Int"
    IRDouble -> "Double"
    IRBool -> "Bool"
    IRString -> "String"
    IRArray a -> "[" <> renderType a <> "]"
    IRClass { name } -> name
    IRUnion s ->  unionName s

renderUnions :: IRType -> Doc Unit
renderUnions = case _ of
    IRUnion s -> do
        renderUnion s
        for_ (S.toUnfoldable s :: Array _) renderUnions
    IRArray (IRUnion s) -> renderUnion s
    _ -> pure unit

unionName :: S.Set IRType -> String
unionName s = intercalate "Or" $ (caseName <$> S.toUnfoldable s :: Array _)

caseName :: IRType -> String
caseName = case _ of
    IRArray a -> renderType a <> "s"
    IRUnion _ ->  "Union"
    t -> renderType t

renderUnion :: S.Set IRType -> Doc Unit
renderUnion types = do
    line $ words ["enum", unionName types, "{"]
    indent do
        for_ types \typ -> line do
            string "case ."
            string $ "some" <> caseName typ
            string "("
            string $ renderType typ
            string ")"
    line "}"
    blank

module Swift
    ( renderSwiftClass
    ) where

import Doc
import IR
import Prelude

import Data.Foldable (for_, intercalate)
import Data.Function (on)
import Data.List (List(..), groupBy)
import Data.List as L
import Data.List.NonEmpty as NE
import Data.Tuple (Tuple(..))
import Data.Map as M

import Data.Set as S

renderSwiftClass :: IRClassData -> Doc Unit
renderSwiftClass { name, properties } = do
    line $ words ["struct", name]
    line "{"
    indent do
        let props = properties # M.toUnfoldable <#> \(Tuple name typ) -> { name, typ }
        let propGroups = L.groupBy (eq `on` _.typ) props
        for_ propGroups renderPropGroup
    line "}"

renderPropGroup :: NE.NonEmptyList { name :: String, typ :: IRType} -> Doc Unit
renderPropGroup props = line do
    let names = intercalate ", " (_.name <$> props)
    words ["let", names <> ":"]
    string " "

    let { typ } = NE.head props
    string $ renderType typ

renderType :: IRType -> String
renderType = case _ of
    IRNothing -> "Any"
    IRNull -> "Any"
    IRInteger -> "Int"
    IRDouble -> "Double"
    IRBool -> "Bool"
    IRString -> "String"
    IRArray a -> "[" <> renderType a <> "]"
    IRClass { name } -> name
    IRUnion s ->  "Either<" <> intercalate ", " (S.map renderType s) <> ">"


Fix statSync exceptions being uncatchable

module Node.FS.Sync
  ( rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  , exists
  , fdOpen
  , fdRead
  , fdNext
  , fdWrite
  , fdAppend
  , fdFlush
  , fdClose
  ) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Date
import Data.Time
import Data.Function
import Data.Nullable (Nullable(), toNullable)
import Data.Int (round)
import Data.Maybe (Maybe(..))
import Node.Buffer (Buffer(), BUFFER(), size)
import Node.Encoding

import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())
import Node.FS.Perms
import Node.FS.Internal

fs ::
  { renameSync :: Fn2 FilePath FilePath Unit
  , truncateSync :: Fn2 FilePath Int Unit
  , chownSync :: Fn3 FilePath Int Int Unit
  , chmodSync :: Fn2 FilePath String Unit
  , statSync :: Fn1 FilePath StatsObj
  , linkSync :: Fn2 FilePath FilePath Unit
  , symlinkSync :: Fn3 FilePath FilePath String Unit
  , readlinkSync :: Fn1 FilePath FilePath
  , realpathSync :: forall cache. Fn2 FilePath { | cache } FilePath
  , unlinkSync :: Fn1 FilePath Unit
  , rmdirSync :: Fn1 FilePath Unit
  , mkdirSync :: Fn2 FilePath String Unit
  , readdirSync :: Fn1 FilePath (Array FilePath)
  , utimesSync :: Fn3 FilePath Int Int Unit
  , readFileSync :: forall a opts. Fn2 FilePath { | opts } a
  , writeFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , appendFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , existsSync :: FilePath -> Boolean
  , openSync :: Fn3 FilePath String (Nullable FileMode) FileDescriptor
  , readSync :: Fn5 FileDescriptor Buffer BufferOffset BufferLength (Nullable FilePosition) ByteCount
  , writeSync :: Fn5 FileDescriptor Buffer BufferOffset BufferLength (Nullable FilePosition) ByteCount
  , fsyncSync :: Fn1 FileDescriptor Unit
  , closeSync :: Fn1 FileDescriptor Unit
  }
fs = unsafeRequireFS

-- | Renames a file.
rename :: forall eff. FilePath
                   -> FilePath
                   -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

rename oldFile newFile = mkEff $ \_ -> runFn2
  fs.renameSync oldFile newFile

-- | Truncates a file to the specified length.
truncate :: forall eff. FilePath
                     -> Int
                     -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

truncate file len = mkEff $ \_ -> runFn2
  fs.truncateSync file len

-- | Changes the ownership of a file.
chown :: forall eff. FilePath
                  -> Int
                  -> Int
                  -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

chown file uid gid = mkEff $ \_ -> runFn3
  fs.chownSync file uid gid

-- | Changes the permissions of a file.
chmod :: forall eff. FilePath
                  -> Perms
                  -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

chmod file perms = mkEff $ \_ -> runFn2
  fs.chmodSync file (permsToString perms)

-- | Gets file statistics.
stat :: forall eff. FilePath
                 -> Eff (fs :: FS, err :: EXCEPTION | eff) Stats

stat file = map Stats $ mkEff $ \_ -> runFn1
  fs.statSync file

-- | Creates a link to an existing file.
link :: forall eff. FilePath
                 -> FilePath
                 -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

link src dst = mkEff $ \_ -> runFn2
  fs.linkSync src dst

-- | Creates a symlink.
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

symlink src dst ty = mkEff $ \_ -> runFn3
  fs.symlinkSync src dst (symlinkTypeToNode ty)

-- | Reads the value of a symlink.
readlink :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: EXCEPTION | eff) FilePath

readlink path = mkEff $ \_ -> runFn1
  fs.readlinkSync path

-- | Find the canonicalized absolute location for a path.
realpath :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: EXCEPTION | eff) FilePath

realpath path = mkEff $ \_ -> runFn2
  fs.realpathSync path {}

-- | Find the canonicalized absolute location for a path using a cache object for
-- | already resolved paths.
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Eff (fs :: FS, err :: EXCEPTION | eff) FilePath

realpath' path cache = mkEff $ \_ -> runFn2
  fs.realpathSync path cache

-- | Deletes a file.
unlink :: forall eff. FilePath
                   -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

unlink file = mkEff $ \_ -> runFn1
  fs.unlinkSync file

-- | Deletes a directory.
rmdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

rmdir file = mkEff $ \_ -> runFn1
  fs.rmdirSync file

-- | Makes a new directory.
mkdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

mkdir = flip mkdir' $ mkPerms all all all

-- | Makes a new directory with the specified permissions.
mkdir' :: forall eff. FilePath
                   -> Perms
                   -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

mkdir' file perms = mkEff $ \_ -> runFn2
  fs.mkdirSync file (permsToString perms)

-- | Reads the contents of a directory.
readdir :: forall eff. FilePath
                    -> Eff (fs :: FS, err :: EXCEPTION | eff) (Array FilePath)

readdir file = mkEff $ \_ -> runFn1
  fs.readdirSync file

-- | Sets the accessed and modified times for the specified file.
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

utimes file atime mtime = mkEff $ \_ -> runFn3
  fs.utimesSync file
                (fromDate atime)
                (fromDate mtime)
  where
  fromDate date = ms (toEpochMilliseconds date) / 1000
  ms (Milliseconds n) = round n

-- | Reads the entire contents of a file returning the result as a raw buffer.
readFile :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: EXCEPTION | eff) Buffer

readFile file = mkEff $ \_ -> runFn2
  fs.readFileSync file {}

-- | Reads the entire contents of a text file with the specified encoding.
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Eff (fs :: FS, err :: EXCEPTION | eff) String

readTextFile encoding file = mkEff $ \_ -> runFn2
  fs.readFileSync file { encoding: show encoding }

-- | Writes a buffer to a file.
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Eff (buffer :: BUFFER, fs :: FS, err :: EXCEPTION | eff) Unit

writeFile file buff = mkEff $ \_ -> runFn3
  fs.writeFileSync file buff {}

-- | Writes text to a file using the specified encoding.
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

writeTextFile encoding file text = mkEff $ \_ -> runFn3
  fs.writeFileSync file text { encoding: show encoding }

-- | Appends the contents of a buffer to a file.
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Eff (buffer :: BUFFER, fs :: FS, err :: EXCEPTION | eff) Unit

appendFile file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff {}

-- | Appends text to a file using the specified encoding.
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

appendTextFile encoding file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff { encoding: show encoding }

-- | Check if the path exists.
exists :: forall eff. FilePath
                   -> Eff (fs :: FS | eff) Boolean
exists file = mkEff $ \_ -> fs.existsSync file

-- | Open a file synchronously. See the [Node documentation](http://nodejs.org/api/fs.html#fs_fs_opensync_path_flags_mode)
-- | for details.
fdOpen :: forall eff.
          FilePath
       -> FileFlags
       -> Maybe FileMode
       -> Eff (err :: EXCEPTION, fs :: FS | eff) FileDescriptor
fdOpen file flags mode = mkEff $ \_ ->
  runFn3 fs.openSync file (fileFlagsToNode flags) (toNullable mode)

-- | Read from a file synchronously. See the [Node documentation](http://nodejs.org/api/fs.html#fs_fs_readsync_fd_buffer_offset_length_position)
-- | for details.
fdRead :: forall eff.
          FileDescriptor
       -> Buffer
       -> BufferOffset
       -> BufferLength
       -> Maybe FilePosition
       -> Eff (buffer :: BUFFER, err :: EXCEPTION, fs :: FS | eff) ByteCount
fdRead fd buff off len pos =
  mkEff $ \_ -> runFn5 fs.readSync fd buff off len (toNullable pos)

-- | Convenience function to fill the whole buffer from the current
-- | file position.
fdNext :: forall eff.
          FileDescriptor
       -> Buffer
       -> Eff (buffer :: BUFFER, err :: EXCEPTION, fs :: FS | eff) ByteCount
fdNext fd buff = do
  sz <- size buff
  fdRead fd buff 0 sz Nothing

-- | Write to a file synchronously. See the [Node documentation](http://nodejs.org/api/fs.html#fs_fs_writesync_fd_buffer_offset_length_position)
-- | for details.
fdWrite :: forall eff.
           FileDescriptor
        -> Buffer
        -> BufferOffset
        -> BufferLength
        -> Maybe FilePosition
        -> Eff (buffer :: BUFFER, err :: EXCEPTION, fs :: FS | eff) ByteCount
fdWrite fd buff off len pos =
  mkEff $ \_ -> runFn5 fs.writeSync fd buff off len (toNullable pos)

-- | Convenience function to append the whole buffer to the current
-- | file position.
fdAppend :: forall eff.
            FileDescriptor
         -> Buffer
         -> Eff (buffer :: BUFFER, err :: EXCEPTION, fs :: FS | eff) ByteCount
fdAppend fd buff = do
  sz <- size buff
  fdWrite fd buff 0 sz Nothing

-- | Flush a file synchronously.  See the [Node documentation](http://nodejs.org/api/fs.html#fs_fs_fsyncsync_fd)
-- | for details.
fdFlush :: forall eff.
           FileDescriptor
        -> Eff (err :: EXCEPTION, fs :: FS | eff) Unit
fdFlush fd = mkEff $ \_ -> runFn1 fs.fsyncSync fd

-- | Close a file synchronously. See the [Node documentation](http://nodejs.org/api/fs.html#fs_fs_closesync_fd)
-- | for details.
fdClose :: forall eff.
           FileDescriptor
        -> Eff (err :: EXCEPTION, fs :: FS | eff) Unit
fdClose fd = mkEff $ \_ -> runFn1 fs.closeSync fd

module Node.FS.Sync
  ( rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  , exists
  , fdOpen
  , fdRead
  , fdNext
  , fdWrite
  , fdAppend
  , fdFlush
  , fdClose
  ) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Date
import Data.Time
import Data.Function
import Data.Nullable (Nullable(), toNullable)
import Data.Int (round)
import Data.Maybe (Maybe(..))
import Node.Buffer (Buffer(), BUFFER(), size)
import Node.Encoding

import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())
import Node.FS.Perms
import Node.FS.Internal

fs ::
  { renameSync :: Fn2 FilePath FilePath Unit
  , truncateSync :: Fn2 FilePath Int Unit
  , chownSync :: Fn3 FilePath Int Int Unit
  , chmodSync :: Fn2 FilePath String Unit
  , statSync :: Fn1 FilePath StatsObj
  , linkSync :: Fn2 FilePath FilePath Unit
  , symlinkSync :: Fn3 FilePath FilePath String Unit
  , readlinkSync :: Fn1 FilePath FilePath
  , realpathSync :: forall cache. Fn2 FilePath { | cache } FilePath
  , unlinkSync :: Fn1 FilePath Unit
  , rmdirSync :: Fn1 FilePath Unit
  , mkdirSync :: Fn2 FilePath String Unit
  , readdirSync :: Fn1 FilePath (Array FilePath)
  , utimesSync :: Fn3 FilePath Int Int Unit
  , readFileSync :: forall a opts. Fn2 FilePath { | opts } a
  , writeFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , appendFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , existsSync :: FilePath -> Boolean
  , openSync :: Fn3 FilePath String (Nullable FileMode) FileDescriptor
  , readSync :: Fn5 FileDescriptor Buffer BufferOffset BufferLength (Nullable FilePosition) ByteCount
  , writeSync :: Fn5 FileDescriptor Buffer BufferOffset BufferLength (Nullable FilePosition) ByteCount
  , fsyncSync :: Fn1 FileDescriptor Unit
  , closeSync :: Fn1 FileDescriptor Unit
  }
fs = unsafeRequireFS

-- | Renames a file.
rename :: forall eff. FilePath
                   -> FilePath
                   -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

rename oldFile newFile = mkEff $ \_ -> runFn2
  fs.renameSync oldFile newFile

-- | Truncates a file to the specified length.
truncate :: forall eff. FilePath
                     -> Int
                     -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

truncate file len = mkEff $ \_ -> runFn2
  fs.truncateSync file len

-- | Changes the ownership of a file.
chown :: forall eff. FilePath
                  -> Int
                  -> Int
                  -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

chown file uid gid = mkEff $ \_ -> runFn3
  fs.chownSync file uid gid

-- | Changes the permissions of a file.
chmod :: forall eff. FilePath
                  -> Perms
                  -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

chmod file perms = mkEff $ \_ -> runFn2
  fs.chmodSync file (permsToString perms)

-- | Gets file statistics.
stat :: forall eff. FilePath
                 -> Eff (fs :: FS, err :: EXCEPTION | eff) Stats

stat file = return $ Stats $ runFn1
  fs.statSync file

-- | Creates a link to an existing file.
link :: forall eff. FilePath
                 -> FilePath
                 -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

link src dst = mkEff $ \_ -> runFn2
  fs.linkSync src dst

-- | Creates a symlink.
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

symlink src dst ty = mkEff $ \_ -> runFn3
  fs.symlinkSync src dst (symlinkTypeToNode ty)

-- | Reads the value of a symlink.
readlink :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: EXCEPTION | eff) FilePath

readlink path = mkEff $ \_ -> runFn1
  fs.readlinkSync path

-- | Find the canonicalized absolute location for a path.
realpath :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: EXCEPTION | eff) FilePath

realpath path = mkEff $ \_ -> runFn2
  fs.realpathSync path {}

-- | Find the canonicalized absolute location for a path using a cache object for
-- | already resolved paths.
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Eff (fs :: FS, err :: EXCEPTION | eff) FilePath

realpath' path cache = mkEff $ \_ -> runFn2
  fs.realpathSync path cache

-- | Deletes a file.
unlink :: forall eff. FilePath
                   -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

unlink file = mkEff $ \_ -> runFn1
  fs.unlinkSync file

-- | Deletes a directory.
rmdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

rmdir file = mkEff $ \_ -> runFn1
  fs.rmdirSync file

-- | Makes a new directory.
mkdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

mkdir = flip mkdir' $ mkPerms all all all

-- | Makes a new directory with the specified permissions.
mkdir' :: forall eff. FilePath
                   -> Perms
                   -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

mkdir' file perms = mkEff $ \_ -> runFn2
  fs.mkdirSync file (permsToString perms)

-- | Reads the contents of a directory.
readdir :: forall eff. FilePath
                    -> Eff (fs :: FS, err :: EXCEPTION | eff) (Array FilePath)

readdir file = mkEff $ \_ -> runFn1
  fs.readdirSync file

-- | Sets the accessed and modified times for the specified file.
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

utimes file atime mtime = mkEff $ \_ -> runFn3
  fs.utimesSync file
                (fromDate atime)
                (fromDate mtime)
  where
  fromDate date = ms (toEpochMilliseconds date) / 1000
  ms (Milliseconds n) = round n

-- | Reads the entire contents of a file returning the result as a raw buffer.
readFile :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: EXCEPTION | eff) Buffer

readFile file = mkEff $ \_ -> runFn2
  fs.readFileSync file {}

-- | Reads the entire contents of a text file with the specified encoding.
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Eff (fs :: FS, err :: EXCEPTION | eff) String

readTextFile encoding file = mkEff $ \_ -> runFn2
  fs.readFileSync file { encoding: show encoding }

-- | Writes a buffer to a file.
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Eff (buffer :: BUFFER, fs :: FS, err :: EXCEPTION | eff) Unit

writeFile file buff = mkEff $ \_ -> runFn3
  fs.writeFileSync file buff {}

-- | Writes text to a file using the specified encoding.
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

writeTextFile encoding file text = mkEff $ \_ -> runFn3
  fs.writeFileSync file text { encoding: show encoding }

-- | Appends the contents of a buffer to a file.
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Eff (buffer :: BUFFER, fs :: FS, err :: EXCEPTION | eff) Unit

appendFile file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff {}

-- | Appends text to a file using the specified encoding.
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Eff (fs :: FS, err :: EXCEPTION | eff) Unit

appendTextFile encoding file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff { encoding: show encoding }

-- | Check if the path exists.
exists :: forall eff. FilePath
                   -> Eff (fs :: FS | eff) Boolean
exists file = return $ fs.existsSync file

-- | Open a file synchronously. See the [Node documentation](http://nodejs.org/api/fs.html#fs_fs_opensync_path_flags_mode)
-- | for details.
fdOpen :: forall eff.
          FilePath
       -> FileFlags
       -> Maybe FileMode
       -> Eff (err :: EXCEPTION, fs :: FS | eff) FileDescriptor
fdOpen file flags mode = mkEff $ \_ ->
  runFn3 fs.openSync file (fileFlagsToNode flags) (toNullable mode)

-- | Read from a file synchronously. See the [Node documentation](http://nodejs.org/api/fs.html#fs_fs_readsync_fd_buffer_offset_length_position)
-- | for details.
fdRead :: forall eff.
          FileDescriptor
       -> Buffer
       -> BufferOffset
       -> BufferLength
       -> Maybe FilePosition
       -> Eff (buffer :: BUFFER, err :: EXCEPTION, fs :: FS | eff) ByteCount
fdRead fd buff off len pos =
  mkEff $ \_ -> runFn5 fs.readSync fd buff off len (toNullable pos)

-- | Convenience function to fill the whole buffer from the current
-- | file position.
fdNext :: forall eff.
          FileDescriptor
       -> Buffer
       -> Eff (buffer :: BUFFER, err :: EXCEPTION, fs :: FS | eff) ByteCount
fdNext fd buff = do
  sz <- size buff
  fdRead fd buff 0 sz Nothing

-- | Write to a file synchronously. See the [Node documentation](http://nodejs.org/api/fs.html#fs_fs_writesync_fd_buffer_offset_length_position)
-- | for details.
fdWrite :: forall eff.
           FileDescriptor
        -> Buffer
        -> BufferOffset
        -> BufferLength
        -> Maybe FilePosition
        -> Eff (buffer :: BUFFER, err :: EXCEPTION, fs :: FS | eff) ByteCount
fdWrite fd buff off len pos =
  mkEff $ \_ -> runFn5 fs.writeSync fd buff off len (toNullable pos)

-- | Convenience function to append the whole buffer to the current
-- | file position.
fdAppend :: forall eff.
            FileDescriptor
         -> Buffer
         -> Eff (buffer :: BUFFER, err :: EXCEPTION, fs :: FS | eff) ByteCount
fdAppend fd buff = do
  sz <- size buff
  fdWrite fd buff 0 sz Nothing

-- | Flush a file synchronously.  See the [Node documentation](http://nodejs.org/api/fs.html#fs_fs_fsyncsync_fd)
-- | for details.
fdFlush :: forall eff.
           FileDescriptor
        -> Eff (err :: EXCEPTION, fs :: FS | eff) Unit
fdFlush fd = mkEff $ \_ -> runFn1 fs.fsyncSync fd

-- | Close a file synchronously. See the [Node documentation](http://nodejs.org/api/fs.html#fs_fs_closesync_fd)
-- | for details.
fdClose :: forall eff.
           FileDescriptor
        -> Eff (err :: EXCEPTION, fs :: FS | eff) Unit
fdClose fd = mkEff $ \_ -> runFn1 fs.closeSync fd


Add pageX/Y properties to mouse events

Add pageX/Y properties to mouse events

-- | Common DOM event types.
module Halogen.HTML.Events.Types where

import Data.Nullable (Nullable())

import DOM.HTML.Types (HTMLElement())
import DOM.Event.DragEvent.DataTransfer (DataTransfer())

-- | This record synonym captures the properties which appear on every DOM event.
-- |
-- | The `fields` type parameter allows us to attach different types of additional
-- | properties to represent more specific types of events.
type Event fields =
  { bubbles :: Boolean
  , cancelable :: Boolean
  , currentTarget :: HTMLElement
  , target :: HTMLElement
  , timeStamp :: Number
  , "type" :: String
  | fields
  }

-- | Identifies the additional fields which are available on mouse events.
type MouseEvent =
  ( button :: Number
  , detail :: Number
  , relatedTarget :: HTMLElement
  , clientX :: Number
  , clientY :: Number
  , pageX :: Number
  , pageY :: Number
  , screenX	:: Number
  , screenY	:: Number
  , ctrlKey	:: Boolean
  , shiftKey :: Boolean
  , altKey :: Boolean
  , metaKey	:: Boolean
  , which :: Number
  )

-- | Identifies the additional fields which are available on drag events.
type DragEvent =
  ( button :: Number
  , detail :: Number
  , relatedTarget :: HTMLElement
  , clientX :: Number
  , clientY :: Number
  , pageX :: Number
  , pageY :: Number
  , screenX	:: Number
  , screenY	:: Number
  , ctrlKey	:: Boolean
  , shiftKey :: Boolean
  , altKey :: Boolean
  , metaKey	:: Boolean
  , which :: Number
  , dataTransfer :: Nullable DataTransfer
  )

-- | Identifies the additional fields which are available on keyboard events.
type KeyboardEvent =
  ( charCode :: Number
  , keyCode :: Number
  , ctrlKey	:: Boolean
  , shiftKey :: Boolean
  , altKey :: Boolean
  , metaKey	:: Boolean
  , which :: Number
  )

-- | Identifies the additional fields which are available on focus events.
type FocusEvent =
  ( relatedTarget :: HTMLElement
  )

-- | Common DOM event types.
module Halogen.HTML.Events.Types where

import Data.Nullable (Nullable())

import DOM.HTML.Types (HTMLElement())
import DOM.Event.DragEvent.DataTransfer (DataTransfer())

-- | This record synonym captures the properties which appear on every DOM event.
-- |
-- | The `fields` type parameter allows us to attach different types of additional
-- | properties to represent more specific types of events.
type Event fields =
  { bubbles :: Boolean
  , cancelable :: Boolean
  , currentTarget :: HTMLElement
  , target :: HTMLElement
  , timeStamp :: Number
  , "type" :: String
  | fields
  }

-- | Identifies the additional fields which are available on mouse events.
type MouseEvent =
  ( button :: Number
  , detail :: Number
  , relatedTarget :: HTMLElement
  , clientX :: Number
  , clientY :: Number
  , screenX	:: Number
  , screenY	:: Number
  , ctrlKey	:: Boolean
  , shiftKey :: Boolean
  , altKey :: Boolean
  , metaKey	:: Boolean
  , which :: Number
  )

-- | Identifies the additional fields which are available on drag events.
type DragEvent =
  ( button :: Number
  , detail :: Number
  , relatedTarget :: HTMLElement
  , clientX :: Number
  , clientY :: Number
  , screenX	:: Number
  , screenY	:: Number
  , ctrlKey	:: Boolean
  , shiftKey :: Boolean
  , altKey :: Boolean
  , metaKey	:: Boolean
  , which :: Number
  , dataTransfer :: Nullable DataTransfer
  )

-- | Identifies the additional fields which are available on keyboard events.
type KeyboardEvent =
  ( charCode :: Number
  , keyCode :: Number
  , ctrlKey	:: Boolean
  , shiftKey :: Boolean
  , altKey :: Boolean
  , metaKey	:: Boolean
  , which :: Number
  )

-- | Identifies the additional fields which are available on focus events.
type FocusEvent =
  ( relatedTarget :: HTMLElement
  )


Update Cache component

Update Cache component

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Cache.Component
  ( cacheCardComponent
  , module SlamData.Workspace.Card.Cache.Component.State
  , module SlamData.Workspace.Card.Cache.Component.Query
  ) where

import SlamData.Prelude

import Data.Lens ((.~), (?~))
import Data.Path.Pathy as Path

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Monad (Slam)
import SlamData.Render.CSS as CSS
import SlamData.Workspace.Card.Cache.Component.Query (Query(..))
import SlamData.Workspace.Card.Cache.Component.State (State, _confirmedPath, _pathString, initialState)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

import Utils.Path as PU

type CacheDSL = H.ComponentDSL State (CC.InnerCardQuery Query) CC.CardEvalMessage Slam
type CacheHTML = H.ComponentHTML (CC.InnerCardQuery Query)

cacheCardComponent ∷ CC.CardOptions → CC.CardComponent
cacheCardComponent =
  CC.makeCardComponent CT.Cache $ H.component
    { render
    , eval: coproduct cardEval saveEval
    , initialState: const initialState
    , receiver: const Nothing
    }

render ∷ State → CacheHTML
render state =
  HH.div
    [ HP.class_ CSS.form ]
    [ HH.input
        [ HP.type_ HP.InputText
        , HP.placeholder "Cache file destination"
        , ARIA.label "Cache file destination"
        , HE.onValueInput $ HE.input \s → right ∘ UpdatePathString s
        , HP.value $ fromMaybe "" state.pathString
        ]
    , HH.button
          [ HP.title "Confirm file destination"
          , ARIA.label "Confirm file destination"
          , HP.disabled $ isNothing $ PU.parseFilePath =<< state.pathString
          , HE.onClick (HE.input_ $ right ∘ ConfirmPathString)
          ]
          [ HH.text "Confirm" ]
    ]

cardEval ∷ CC.CardEvalQuery ~> CacheDSL
cardEval = case _ of
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    k ∘ Card.Cache ∘ map Path.printPath <$> H.gets _.confirmedPath
  CC.Load card next → do
    case card of
      Card.Cache s →
        H.modify
          $ (_pathString .~ s)
          ∘ (_confirmedPath .~ (PU.parseFilePath =<< s))
      _ → pure unit
    pure next
  CC.ReceiveInput _ _ next →
    pure next
  CC.ReceiveOutput _ varMap next → do
    for_ (Port.extractFilePath varMap) \resource →
      H.modify
        $ (_pathString ?~ Path.printPath resource)
        ∘ (_confirmedPath ?~ resource)
    pure next
  CC.ReceiveState input next →
    pure next
  CC.ReceiveDimensions _ reply →
    pure (reply High)

saveEval ∷ Query ~> CacheDSL
saveEval = case _ of
  UpdatePathString str next →
    H.modify (_pathString ?~ str) $> next
  ConfirmPathString next → do
    pathString ← H.gets _.pathString
    H.modify $ \st → st { confirmedPath = PU.parseFilePath =<< pathString }
    H.raise CC.modelUpdate
    pure next

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Cache.Component
  ( cacheCardComponent
  , module SlamData.Workspace.Card.Cache.Component.State
  , module SlamData.Workspace.Card.Cache.Component.Query
  ) where

import SlamData.Prelude

import Data.Lens ((.~), (?~))
import Data.Path.Pathy as Path

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Monad (Slam)
import SlamData.Render.CSS as CSS
import SlamData.Workspace.Card.Cache.Component.Query (QueryP, Query(..))
import SlamData.Workspace.Card.Cache.Component.State (State, _confirmedPath, _pathString, initialState)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as Port

import Utils.Path as PU

type CacheHTML = H.ComponentHTML QueryP
type CacheDSL = H.ComponentDSL State QueryP Slam

cacheCardComponent ∷ CC.CardOptions → CC.CardComponent
cacheCardComponent options = CC.makeCardComponent
  { options
  , cardType: CT.Cache
  , component: H.component { render, eval }
  , initialState: initialState
  , _State: CC._CacheState
  , _Query: CC.makeQueryPrism CC._CacheQuery
  }

render ∷ State → CacheHTML
render state =
  HH.div
    [ HP.class_ CSS.form ]
    [ HH.input
        [ HP.type_ HP.InputText
        , HP.placeholder "Cache file destination"
        , ARIA.label "Cache file destination"
        , HE.onValueInput $ HE.input \s → right ∘ UpdatePathString s
        , HP.value $ fromMaybe "" state.pathString
        ]
    , HH.button
          [ HP.title "Confirm file destination"
          , ARIA.label "Confirm file destination"
          , HP.disabled $ isNothing $ PU.parseFilePath =<< state.pathString
          , HE.onClick (HE.input_ $ right ∘ ConfirmPathString)
          ]
          [ HH.text "Confirm" ]
    ]

eval ∷ QueryP ~> CacheDSL
eval = coproduct cardEval saveEval

cardEval ∷ CC.CardEvalQuery ~> CacheDSL
cardEval = case _ of
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    k ∘ Card.Cache ∘ map Path.printPath <$> H.gets _.confirmedPath
  CC.Load card next → do
    case card of
      Card.Cache s →
        H.modify
          $ (_pathString .~ s)
          ∘ (_confirmedPath .~ (PU.parseFilePath =<< s))
      _ → pure unit
    pure next
  CC.ReceiveInput _ _ next →
    pure next
  CC.ReceiveOutput _ varMap next → do
    for_ (Port.extractFilePath varMap) \resource →
      H.modify
        $ (_pathString ?~ Path.printPath resource)
        ∘ (_confirmedPath ?~ resource)
    pure next
  CC.ReceiveState input next →
    pure next
  CC.ReceiveDimensions _ next →
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

saveEval ∷ Query ~> CacheDSL
saveEval = case _ of
  UpdatePathString str next →
    H.modify (_pathString ?~ str) $> next
  ConfirmPathString next → do
    pathString ← H.gets _.pathString
    H.modify $ \st → st { confirmedPath = PU.parseFilePath =<< pathString }
    CC.raiseUpdatedC' CC.EvalModelUpdate
    pure next


Set initial pitch so the camera is pointing at the cube.

-- | Pure functions and types representing the state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

-- | State of the cube. Direction is clockwise or anticlockwise rotation about the positive y axis. Angle is the angle
-- | of anticlockwise rotation about the positive y axis.
newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

-- | State of the camera. Yaw is anticlockwise rotation in radians about the positive y axis, pitch is anticlockwise rotation in radians about the
-- | positive x axis after it has been transformed for the yaw. At zero pitch and zero yaw, the camera points in the negative z direction.
newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 1.5 (-6.0)},
  camera: CameraState {pitch: 0.25, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 0.5

-- | The rate equation!
applyRate :: Number -> Seconds -> Number
applyRate v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 1.0

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: true, a: true, d: true, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: true, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: true}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: true}) = i3
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * applyRate angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale (applyRate movementRate stepSeconds) $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw - dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p

-- | Pure functions and types representing the state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

-- | State of the cube. Direction is clockwise or anticlockwise rotation about the positive y axis. Angle is the angle
-- | of anticlockwise rotation about the positive y axis.
newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

-- | State of the camera. Yaw is anticlockwise rotation in radians about the positive y axis, pitch is anticlockwise rotation in radians about the
-- | positive x axis after it has been transformed for the yaw. At zero pitch and zero yaw, the camera points in the negative z direction.
newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 1.5 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 0.5

-- | The rate equation!
applyRate :: Number -> Seconds -> Number
applyRate v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 1.0

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: true, a: true, d: true, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: true, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: true}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: true}) = i3
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * applyRate angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale (applyRate movementRate stepSeconds) $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw - dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p


Use `where` clause to group trim functions

module Test.Spec.Runner
  ( run
  , runSpec
  ) where

import Prelude

import Control.Monad.Aff           (Aff(), runAff, attempt)
import Control.Monad.Eff           (Eff())
import Control.Monad.Eff.Console   (CONSOLE(), logShow)
import Control.Monad.Eff.Exception (Error)
import Control.Alt                 ((<|>))

import Data.Array                (singleton)
import Data.Maybe                (Maybe(..), fromMaybe)
import Data.Either               (either)
import Data.Foldable             (foldl, sequence_)
import Data.Traversable          (sequence)

import Test.Spec                (Spec(), Group(..), Result(..), collect)
import Test.Spec.Console        (withAttrs)
import Test.Spec.Summary        (successful)
import Test.Spec.Reporter       (Reporter())

import Node.Process (PROCESS())
import Node.Process as Process

runCatch :: forall r. Group (Aff r Unit)
         -> Aff r (Group Result)
runCatch group =
  case group of
    It only name test -> do
      let onError e = pure $ It only name $ Failure e
          onSuccess _ = pure $ It only name Success
      e <- attempt test
      either onError onSuccess e
    Describe only name groups -> do
      results <- sequence (map runCatch groups)
      pure (Describe only name results)
    Pending name -> pure (Pending name)

trim :: ∀ r. Array (Group r) -> Array (Group r)
trim xs = fromMaybe xs (singleton <$> findJust findOnly xs)
  where
  findOnly :: Group r -> Maybe (Group r)
  findOnly g@(It true _ _) = pure g
  findOnly g@(Describe o _ gs) = findJust findOnly gs <|> if o then pure g
                                                               else Nothing
  findOnly _ = Nothing

  findJust :: forall a. (a -> Maybe a) -> Array a -> Maybe a
  findJust f = foldl go Nothing
    where
    go Nothing x = f x
    go acc _     = acc

runSpec :: forall r. Spec r Unit
         -> Aff r (Array (Group Result))
runSpec = sequence <<< map runCatch <<< trim <<< collect

-- Runs the tests and invoke all reporters.
-- If run in a NodeJS environment any failed test will cause the
-- process to exit with a non-zero exit code. On success it will
-- exit with a zero exit code explicitly, so passing integration tests that still have
-- connections open can run in CI successfully.
run :: forall e.
    Array (Reporter (process :: PROCESS, console :: CONSOLE | e))
    -> Spec (process :: PROCESS, console :: CONSOLE | e) Unit
    -> Eff  (process :: PROCESS, console :: CONSOLE | e) Unit
run rs spec = do
  _ <- runAff onError onSuccess (runSpec spec)
  pure unit
  where
    onError :: Error -> Eff (process :: PROCESS, console :: CONSOLE | e) Unit
    onError err = do withAttrs [31] $ logShow err
                     Process.exit 1
    onSuccess :: Array (Group Result) -> Eff (process :: PROCESS, console :: CONSOLE | e) Unit
    onSuccess results = do sequence_ (map (\f -> f results) rs)
                           if (successful results)
                             then Process.exit 0
                             else Process.exit 1

module Test.Spec.Runner
  ( run
  , runSpec
  ) where

import Prelude

import Control.Monad.Aff           (Aff(), runAff, attempt)
import Control.Monad.Eff           (Eff())
import Control.Monad.Eff.Console   (CONSOLE(), logShow)
import Control.Monad.Eff.Exception (Error)
import Control.Alt                 ((<|>))

import Data.Array                (singleton)
import Data.Maybe                (Maybe(..), fromMaybe)
import Data.Either               (either)
import Data.Foldable             (foldl, sequence_)
import Data.Traversable          (sequence)

import Test.Spec                (Spec(), Group(..), Result(..), collect)
import Test.Spec.Console        (withAttrs)
import Test.Spec.Summary        (successful)
import Test.Spec.Reporter       (Reporter())

import Node.Process (PROCESS())
import Node.Process as Process

runCatch :: forall r. Group (Aff r Unit)
         -> Aff r (Group Result)
runCatch group =
  case group of
    It only name test -> do
      let onError e = pure $ It only name $ Failure e
          onSuccess _ = pure $ It only name Success
      e <- attempt test
      either onError onSuccess e
    Describe only name groups -> do
      results <- sequence (map runCatch groups)
      pure (Describe only name results)
    Pending name -> pure (Pending name)

findOnly :: forall r. Group r -> Maybe (Group r)
findOnly g@(It true _ _) = pure g
findOnly g@(Describe o _ gs) = findJust findOnly gs <|> if o then pure g
                                                             else Nothing
findOnly _ = Nothing

findJust :: forall a. (a -> Maybe a) -> Array a -> Maybe a
findJust f = foldl go Nothing
  where
  go Nothing x = f x
  go acc _     = acc

trim :: ∀ r. Array (Group r) -> Array (Group r)
trim xs = fromMaybe xs (singleton <$> findJust findOnly xs)

runSpec :: forall r. Spec r Unit
         -> Aff r (Array (Group Result))
runSpec = sequence <<< map runCatch <<< trim <<< collect

-- Runs the tests and invoke all reporters.
-- If run in a NodeJS environment any failed test will cause the
-- process to exit with a non-zero exit code. On success it will
-- exit with a zero exit code explicitly, so passing integration tests that still have
-- connections open can run in CI successfully.
run :: forall e.
    Array (Reporter (process :: PROCESS, console :: CONSOLE | e))
    -> Spec (process :: PROCESS, console :: CONSOLE | e) Unit
    -> Eff  (process :: PROCESS, console :: CONSOLE | e) Unit
run rs spec = do
  _ <- runAff onError onSuccess (runSpec spec)
  pure unit
  where
    onError :: Error -> Eff (process :: PROCESS, console :: CONSOLE | e) Unit
    onError err = do withAttrs [31] $ logShow err
                     Process.exit 1
    onSuccess :: Array (Group Result) -> Eff (process :: PROCESS, console :: CONSOLE | e) Unit
    onSuccess results = do sequence_ (map (\f -> f results) rs)
                           if (successful results)
                             then Process.exit 0
                             else Process.exit 1


Fixed typo

Fixed typo

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Quasar.Auth.Authentication
  ( authentication
  , getIdTokenFromBusSilently
  , toNotificationOptions
  , AuthEffects
  , EIdToken
  , AuthenticationError(..)
  , RequestIdTokenBus
  , RequestIdTokenMessage
  ) where

import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW, BusW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Eff.Now (NOW)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (Ref, REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Rec.Class (forever)
import Control.Parallel.Class (race)
import Control.UI.Browser as Browser
import DOM (DOM)
import DOM.HTML as DOMHTML
import DOM.HTML.Document as DOMHTMLDocument
import DOM.HTML.HTMLIFrameElement as DOMHTMLIFrameElement
import DOM.HTML.Types (HTMLIFrameElement)
import DOM.HTML.Types as DOMHTMLTypes
import DOM.HTML.Window as DOMHTMLWindow
import DOM.Node.Document as DOMNodeDocument
import DOM.Node.Node as DOMNode
import DOM.Node.Types (Node, Element)
import Data.Foldable as F
import Data.Foreign as Foreign
import Data.Nullable as Nullable
import Data.Time.Duration (Milliseconds(Milliseconds), Seconds(Seconds))
import Data.Traversable as T
import OIDC.Aff as OIDCAff
import OIDC.Crypt as OIDCCrypt
import OIDC.Crypt.JSONWebKey (JSONWebKey)
import OIDC.Crypt.Types (IdToken(..), UnhashedNonce(..))
import Quasar.Advanced.Types (ProviderR)
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Notification (NotificationOptions)
import SlamData.Notification as Notification
import SlamData.Prelude
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import SlamData.Quasar.Auth.Store as AuthStore

import Text.Parsing.StringParser (ParseError(..))

import Utils (passover)
import Utils.LocalStorage as LocalStorage
import Utils.DOM as DOMUtils

getIdTokenFromBusSilently ∷ ∀ eff. RequestIdTokenBus → Aff (AuthEffects eff) (Either String EIdToken)
getIdTokenFromBusSilently requestIdTokenBus =
  liftEff getProviderRUsingLocalStorage
    >>= case _ of
      Right providerR → do
        idTokenVar ← AVar.makeVar
        Bus.write { idToken: idTokenVar, providerR, prompt: false } requestIdTokenBus
        idToken ← Right <$> AVar.takeVar idTokenVar
        pure idToken
      Left error → pure $ Left error

data AuthenticationError
  = IdTokenInvalid (Maybe Error)
  | IdTokenUnavailable String
  | PromptDismissed
  | DOMError String
  | ProviderError String

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

type RequestIdTokenMessage = { providerR ∷ ProviderR, prompt ∷ Boolean, idToken ∷ AVar EIdToken }

type RequestIdTokenBus = BusW RequestIdTokenMessage

type EIdToken = Either AuthenticationError IdToken

type AuthEffects eff =
  ( now ∷ NOW
  , avar ∷ AVAR
  , ref ∷ REF
  , dom ∷ DOM
  , random ∷ RANDOM
  | eff)

firstValueFromStallingProducer
  ∷ forall o eff
  . StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit
  → AffAVar eff o
firstValueFromStallingProducer producer = do
  firstValue ← AVar.makeVar
  Aff.forkAff
    $ StallingCoroutine.runStallingProcess
        (producer $$? (Coroutine.consumer \o → liftAff (AVar.putVar firstValue o) $> Just unit))
  val ← AVar.takeVar firstValue
  pure val

writeOnlyBus ∷ ∀ a. BusRW a → BusW a
writeOnlyBus = snd ∘ Bus.split

-- | Write an AVar to the returned bus to get a valid OIDC id token from the given provider.
authentication ∷ ∀ eff. Aff (AuthEffects eff) RequestIdTokenBus
authentication = do
  stateRef ← liftEff $ Ref.newRef Nothing
  requestBus ← Bus.make
  Aff.forkAff $ forever (authenticate stateRef =<< Bus.read requestBus)
  pure $ writeOnlyBus requestBus

-- TODO: Allow multiple concurrent auth requests with different providers
-- and prompt options. Alternatively immediately respond with an
-- "authentication already in progress" error.
--
-- Currently if a message comes in whilst authentication is in progress the
-- sender will be given the id token from the in progress auth regardless of
-- what provider they asked for.
--
-- In current use this won't happen but it could if things change.
--
-- The same thing and worse could happen before but it was obscured by the
-- "store provider in localstorage then put a message on the bus" approach.
authenticate
  ∷ ∀ eff
  . Ref (Maybe (Promise EIdToken))
  → RequestIdTokenMessage
  → Aff (AuthEffects eff) Unit
authenticate stateRef message = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenPromise ← getIdToken message.providerR message.prompt
      writeState $ Just idTokenPromise
      void $ Aff.forkAff $ reply idTokenPromise *> writeState Nothing
    Just idTokenPromise → do
      void $ Aff.forkAff $ reply idTokenPromise
  where
  writeState ∷ Maybe (Promise EIdToken) → Aff (AuthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

  reply ∷ Promise EIdToken → Aff (AuthEffects eff) Unit
  reply = AVar.putVar message.idToken <=< Promise.wait

getIdTokenSilently
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenSilently providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  appendHiddenRequestIFrameToBody unhashedNonce providerR
    >>= case _ of
      Left error → pure $ Left error
      Right iFrameNode → do
        idToken ← race (getIdTokenFromLSOnChange providerR unhashedNonce) timeout
        liftEff $ removeBodyChild iFrameNode
        pure idToken
  where
  appendHiddenRequestIFrameToBody unhashedNonce providerR =
    either
      (pure ∘ Left)
      (liftEff ∘ map (lmap DOMError) ∘ appendHiddenIFrameToBody)
      =<< getAuthenticationUri OIDCAff.None unhashedNonce providerR
  timeout =
    Aff.later' Config.authenticationTimeout
      $ pure $ Left $ IdTokenUnavailable "No id token received before timeout."

getIdTokenUsingPrompt
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenUsingPrompt providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  race
    (getIdTokenFromLSOnChange providerR unhashedNonce)
    (prompt unhashedNonce)
  where
  popup src =
    liftEff (DOMUtils.openPopup src)
      >>= case _ of
        Just window → do
          DOMUtils.waitUntilWindowClosed window
          Aff.later' 250 (pure $ Left PromptDismissed)
        Nothing →
          pure $ Left $ DOMError "`window.open` returned null"
  prompt unhashedNonce =
    (either (pure ∘ Left) popup)
      =<< getAuthenticationUri OIDCAff.Login unhashedNonce providerR

getAuthenticationUri
  ∷ ∀ eff
  . OIDCAff.Prompt
  → UnhashedNonce
  → ProviderR
  → Aff (AuthEffects eff) (Either AuthenticationError String)
getAuthenticationUri prompt unhashedNonce providerR =
  (bimap (ProviderError ∘ runParseError) id)
    <$> (liftEff
           $ OIDCAff.getAuthenticationUri prompt unhashedNonce providerR
           =<< getRedirectUri)

appendHiddenIFrameToBody ∷ ∀ eff. String → Eff (AuthEffects eff) (Either String Node)
appendHiddenIFrameToBody uri =
  either
    (pure ∘ Left)
    (appendIFrameToBody <=< configureHiddenIFrame uri)
    =<< createIFrameElement

configureHiddenIFrame
  ∷ ∀ eff
  . String
  → HTMLIFrameElement
  → Eff (AuthEffects eff) HTMLIFrameElement
configureHiddenIFrame uri iFrameElement = do
  DOMHTMLIFrameElement.setSrc uri iFrameElement
  DOMHTMLIFrameElement.setWidth "0" iFrameElement
  DOMHTMLIFrameElement.setHeight "0" iFrameElement
  pure iFrameElement

appendIFrameToBody
  ∷ ∀ eff
  . HTMLIFrameElement
  → Eff (AuthEffects eff) (Either String Node)
appendIFrameToBody iFrameElement =
  traverse (appendIFrameToNode iFrameElement) =<< getBodyNode

appendIFrameToNode
  ∷ ∀ eff
  . HTMLIFrameElement
  → Node
  → Eff (AuthEffects eff) Node
appendIFrameToNode iFrameElement node =
  passover (flip DOMNode.appendChild node)
    $ DOMHTMLTypes.htmlElementToNode
    $ DOMHTMLTypes.htmlIFrameElementToHTMLElement iFrameElement

createIFrameElement ∷ ∀ eff. Eff (AuthEffects eff) (Either String HTMLIFrameElement)
createIFrameElement =
  (lmap show ∘ DOMHTMLTypes.readHTMLIFrameElement ∘ Foreign.toForeign)
    <$> createElement "iframe"

createElement ∷ ∀ eff.  String → Eff (AuthEffects eff) Element
createElement name =
  DOMNodeDocument.createElement name
    ∘ DOMHTMLTypes.htmlDocumentToDocument
    =<< DOMHTMLWindow.document
    =<< DOMHTML.window

removeBodyChild ∷ ∀ eff.  Node → Eff (AuthEffects eff) (Either String Node)
removeBodyChild child =
  either (pure ∘ Left) (map Right ∘ DOMNode.removeChild child) =<< getBodyNode

getBodyNode ∷ ∀ eff. Eff (AuthEffects eff) (Either String Node)
getBodyNode =
  toEitherStringNode
    <$> (DOMHTMLDocument.body =<< DOMHTMLWindow.document =<< DOMHTML.window)
  where
  toEitherStringNode =
    maybe
      (Left "Couldn't find body element.")
      Right
      ∘ map DOMHTMLTypes.htmlElementToNode
      ∘ Nullable.toMaybe

getIdToken
  ∷ ∀ eff
  . ProviderR
  → Boolean
  → Aff (AuthEffects eff) (Promise EIdToken)
getIdToken providerR prompt =
  Promise.defer do
    idToken ← if prompt
      then
        getIdTokenUsingPrompt providerR
      else
        getIdTokenUsingLocalStorage providerR
          >>= maybe (getIdTokenSilently providerR) (pure ∘ Right)
    -- Store provider for future local storage gets and reauthentications
    either
      (const $ liftEff $ AuthStore.clearProvider *> AuthStore.clearIdToken)
      (const $ liftEff $ AuthStore.storeProvider $ QAT.Provider providerR)
      idToken
    pure idToken

getIdTokenUsingLocalStorage ∷ ∀ eff. ProviderR → Aff (AuthEffects eff) (Maybe IdToken)
getIdTokenUsingLocalStorage providerR = do
  eitherIdToken ← getUnverifiedIdTokenUsingLocalStorage
  eitherUnhashedNonce ← getUnhashedNonceUsingLocalStorage
  case Tuple eitherIdToken eitherUnhashedNonce of
    Tuple (Right idToken) (Right unhashedNonce) →
      either (const $ Nothing) (if _ then (Just idToken) else Nothing)
        <$> (liftEff $ verify providerR unhashedNonce idToken)
    Tuple _ _ → pure Nothing

getUnverifiedIdTokenUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenUsingLocalStorage =
  flip bind (map IdToken)
    <$> LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

getUnhashedNonceUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String UnhashedNonce)
getUnhashedNonceUsingLocalStorage =
  rmap UnhashedNonce <$> LocalStorage.getLocalStorage AuthKeys.nonceLocalStorageKey

getProviderRUsingLocalStorage ∷ ∀ eff. Eff (AuthEffects eff) (Either String QAT.ProviderR)
getProviderRUsingLocalStorage =
  map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

getIdTokenFromLSOnChange
  ∷ ∀ eff
  . ProviderR
  → UnhashedNonce
  → Aff (AuthEffects eff) EIdToken
getIdTokenFromLSOnChange providerR unhashedNonce =
  getUnverifiedIdTokenFromLSOnChange
    >>= case _ of
          Left localStorageError →
            pure $ Left $ IdTokenUnavailable localStorageError
          Right idToken →
            either
              (Left ∘ IdTokenInvalid ∘ Just )
              (if _ then Right idToken else Left $ IdTokenInvalid Nothing)
              <$> (liftEff $ verify providerR unhashedNonce idToken)

getUnverifiedIdTokenFromLSOnChange
  ∷ ∀ eff
  . Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenFromLSOnChange =
  _.newValue <$> (firstValueFromStallingProducer =<< liftEff getIdTokenStorageEvents)

runParseError ∷ ParseError → String
runParseError (ParseError s) = s

-- TODO: Remove g
verify ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → Eff (AuthEffects eff) (Either Error Boolean)
verify providerR unhashedNonce idToken =
  F.foldl accumulateErrorsAcceptTrues (Right false)
    <$> T.traverse
          (verifyWithJwk providerR unhashedNonce idToken)
          providerR.openIDConfiguration.jwks
  where
  accumulateErrorsAcceptTrues ∷ Either Error Boolean → Either Error Boolean → Either Error Boolean
  accumulateErrorsAcceptTrues =
    case _, _ of
      _, Right true → Right true
      Right true, _ → Right true
      Left acc, Left error →
        Left $ Exception.error $ (Exception.message acc) <> " " <> (Exception.message error)
      Right false, Left error → Left error
      Right false, Right false → Right false
      Left acc, Right false → Left acc

verifyWithJwk ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → JSONWebKey → Eff (AuthEffects eff) (Either Error Boolean)
verifyWithJwk providerR unhashedNonce idToken jwk = do
  OIDCCrypt.verifyIdToken
      (Seconds 1.0)
      idToken
      providerR.openIDConfiguration.issuer
      providerR.clientID
      unhashedNonce
      jwk

getRedirectUri ∷ ∀ eff. Eff (AuthEffects eff) String
getRedirectUri = (_ <> Config.redirectURIString) <$> Browser.locationString

toNotificationOptions ∷ AuthenticationError → Maybe NotificationOptions
toNotificationOptions =
  case _ of
    IdTokenInvalid error →
      Just
        { notification: Notification.Error $ "Sign in failed: Authentication provider provided invalid id token."
        , detail: Notification.Details ∘ Exception.message <$> error
        , timeout
        , actionOptions: Nothing
        }
    IdTokenUnavailable detail →
      Just
      { notification:
          Notification.Error
            $ "Sign in failed: Authentication provider didn't provide a token. This might happen if you are signed into multiple accounts with your authentication provider."
        , detail: Just $ Notification.Details detail
        , timeout
        , actionOptions: Nothing
        }
    PromptDismissed →
      Just
        { notification: Notification.Warning $ "Sign in prompt closed."
        , detail: Nothing
        , timeout
        , actionOptions: Nothing
        }
    ProviderError detail →
      Just
        { notification: Notification.Error $ "Sign in failed: There was a problem with your provider configuration, please update your SlamData configuration and try again."
        , detail: Just $ Notification.Details detail
        , timeout
        , actionOptions: Nothing
        }
    DOMError _ → Nothing
  where
  timeout = Just $ Milliseconds 5000.0

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Quasar.Auth.Authentication
  ( authentication
  , getIdTokenFromBusSilently
  , toNotificationOptions
  , AuthEffects
  , EIdToken
  , AuthenticationError(..)
  , RequestIdTokenBus
  , RequestIdTokenMessage
  ) where

import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW, BusW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Eff.Now (NOW)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (Ref, REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Rec.Class (forever)
import Control.Parallel.Class (race)
import Control.UI.Browser as Browser
import DOM (DOM)
import DOM.HTML as DOMHTML
import DOM.HTML.Document as DOMHTMLDocument
import DOM.HTML.HTMLIFrameElement as DOMHTMLIFrameElement
import DOM.HTML.Types (HTMLIFrameElement)
import DOM.HTML.Types as DOMHTMLTypes
import DOM.HTML.Window as DOMHTMLWindow
import DOM.Node.Document as DOMNodeDocument
import DOM.Node.Node as DOMNode
import DOM.Node.Types (Node, Element)
import Data.Foldable as F
import Data.Foreign as Foreign
import Data.Nullable as Nullable
import Data.Time.Duration (Milliseconds(Milliseconds), Seconds(Seconds))
import Data.Traversable as T
import OIDC.Aff as OIDCAff
import OIDC.Crypt as OIDCCrypt
import OIDC.Crypt.JSONWebKey (JSONWebKey)
import OIDC.Crypt.Types (IdToken(..), UnhashedNonce(..))
import Quasar.Advanced.Types (ProviderR)
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Notification (NotificationOptions)
import SlamData.Notification as Notification
import SlamData.Prelude
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import SlamData.Quasar.Auth.Store as AuthStore

import Text.Parsing.StringParser (ParseError(..))

import Utils (passover)
import Utils.LocalStorage as LocalStorage
import Utils.DOM as DOMUtils

getIdTokenFromBusSilently ∷ ∀ eff. RequestIdTokenBus → Aff (AuthEffects eff) (Either String EIdToken)
getIdTokenFromBusSilently requestIdTokenBus =
  liftEff getProviderRUsingLocalStorage
    >>= case _ of
      Right providerR → do
        idTokenVar ← AVar.makeVar
        Bus.write { idToken: idTokenVar, providerR, prompt: false } requestIdTokenBus
        idToken ← Right <$> AVar.takeVar idTokenVar
        pure idToken
      Left error → pure $ Left error

data AuthenticationError
  = IdTokenInvalid (Maybe Error)
  | IdTokenUnavailable String
  | PromptDismissed
  | DOMError String
  | ProviderError String

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

type RequestIdTokenMessage = { providerR ∷ ProviderR, prompt ∷ Boolean, idToken ∷ AVar EIdToken }

type RequestIdTokenBus = BusW RequestIdTokenMessage

type EIdToken = Either AuthenticationError IdToken

type AuthEffects eff =
  ( now ∷ NOW
  , avar ∷ AVAR
  , ref ∷ REF
  , dom ∷ DOM
  , random ∷ RANDOM
  | eff)

firstValueFromStallingProducer
  ∷ forall o eff
  . StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit
  → AffAVar eff o
firstValueFromStallingProducer producer = do
  firstValue ← AVar.makeVar
  Aff.forkAff
    $ StallingCoroutine.runStallingProcess
        (producer $$? (Coroutine.consumer \o → liftAff (AVar.putVar firstValue o) $> Just unit))
  val ← AVar.takeVar firstValue
  pure val

writeOnlyBus ∷ ∀ a. BusRW a → BusW a
writeOnlyBus = snd ∘ Bus.split

-- | Write an AVar to the returned bus to get a valid OIDC id token from the given provider.
authentication ∷ ∀ eff. Aff (AuthEffects eff) RequestIdTokenBus
authentication = do
  stateRef ← liftEff $ Ref.newRef Nothing
  requestBus ← Bus.make
  Aff.forkAff $ forever (authenticate stateRef =<< Bus.read requestBus)
  pure $ writeOnlyBus requestBus

-- TODO: Allow multiple concurrent auth requests with different providers
-- and prompt options. Alternatively immediately respond with an
-- "authentication already in progress" error.
--
-- Currently if a message comes in whilst authentication is in progress the
-- sender will be given the id token from the in progress auth regardless of
-- what provider they asked for.
--
-- In current use this won't happen but it could if things change.
--
-- The same thing and worse could happen before but it was obscured by the
-- "store provider in localstorage then put a message on the bus" approach.
authenticate
  ∷ ∀ eff
  . Ref (Maybe (Promise EIdToken))
  → RequestIdTokenMessage
  → Aff (AuthEffects eff) Unit
authenticate stateRef message = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenPromise ← getIdToken message.providerR message.prompt
      writeState $ Just idTokenPromise
      void $ Aff.forkAff $ reply idTokenPromise *> writeState Nothing
    Just idTokenPromise → do
      void $ Aff.forkAff $ reply idTokenPromise
  where
  writeState ∷ Maybe (Promise EIdToken) → Aff (AuthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

  reply ∷ Promise EIdToken → Aff (AuthEffects eff) Unit
  reply = AVar.putVar message.idToken <=< Promise.wait

getIdTokenSilently
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenSilently providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  appendHiddenRequestIFrameToBody unhashedNonce providerR
    >>= case _ of
      Left error → pure $ Left error
      Right iFrameNode → do
        idToken ← race (getIdTokenFromLSOnChange providerR unhashedNonce) timeout
        liftEff $ removeBodyChild iFrameNode
        pure idToken
  where
  appendHiddenRequestIFrameToBody unhashedNonce providerR =
    either
      (pure ∘ Left)
      (liftEff ∘ map (lmap DOMError) ∘ appendHiddenIFrameToBody)
      =<< getAuthenticationUri OIDCAff.None unhashedNonce providerR
  timeout =
    Aff.later' Config.authenticationTimeout
      $ pure $ Left $ IdTokenUnavailable "No id token received before timeout."

getIdTokenUsingPrompt
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenUsingPrompt providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  race
    (getIdTokenFromLSOnChange providerR unhashedNonce)
    (prompt unhashedNonce)
  where
  popup src =
    liftEff (DOMUtils.openPopup src)
      >>= case _ of
        Just window → do
          DOMUtils.waitUntilWindowClosed window
          Aff.later' 250 (pure $ Left PromptDismissed)
        Nothing →
          pure $ Left $ DOMError "`window.open` returned null"
  prompt unhashedNonce =
    (either (pure ∘ Left) popup)
      =<< getAuthenticationUri OIDCAff.Login unhashedNonce providerR

getAuthenticationUri
  ∷ ∀ eff
  . OIDCAff.Prompt
  → UnhashedNonce
  → ProviderR
  → Aff (AuthEffects eff) (Either AuthenticationError String)
getAuthenticationUri prompt unhashedNonce providerR =
  (bimap (ProviderError ∘ runParseError) id)
    <$> (liftEff
           $ OIDCAff.getAuthenticationUri prompt unhashedNonce providerR
           =<< getRedirectUri)

appendHiddenIFrameToBody ∷ ∀ eff. String → Eff (AuthEffects eff) (Either String Node)
appendHiddenIFrameToBody uri =
  either
    (pure ∘ Left)
    (appendIFrameToBody <=< configureHiddenIFrame uri)
    =<< createIFrameElement

configureHiddenIFrame
  ∷ ∀ eff
  . String
  → HTMLIFrameElement
  → Eff (AuthEffects eff) HTMLIFrameElement
configureHiddenIFrame uri iFrameElement = do
  DOMHTMLIFrameElement.setSrc uri iFrameElement
  DOMHTMLIFrameElement.setWidth "0" iFrameElement
  DOMHTMLIFrameElement.setHeight "0" iFrameElement
  pure iFrameElement

appendIFrameToBody
  ∷ ∀ eff
  . HTMLIFrameElement
  → Eff (AuthEffects eff) (Either String Node)
appendIFrameToBody iFrameElement =
  traverse (appendIFrameToNode iFrameElement) =<< getBodyNode

appendIFrameToNode
  ∷ ∀ eff
  . HTMLIFrameElement
  → Node
  → Eff (AuthEffects eff) Node
appendIFrameToNode iFrameElement node =
  passover (flip DOMNode.appendChild node)
    $ DOMHTMLTypes.htmlElementToNode
    $ DOMHTMLTypes.htmlIFrameElementToHTMLElement iFrameElement

createIFrameElement ∷ ∀ eff. Eff (AuthEffects eff) (Either String HTMLIFrameElement)
createIFrameElement =
  (lmap show ∘ DOMHTMLTypes.readHTMLIFrameElement ∘ Foreign.toForeign)
    <$> createElement "iframe"

createElement ∷ ∀ eff.  String → Eff (AuthEffects eff) Element
createElement name =
  DOMNodeDocument.createElement name
    ∘ DOMHTMLTypes.htmlDocumentToDocument
    =<< DOMHTMLWindow.document
    =<< DOMHTML.window

removeBodyChild ∷ ∀ eff.  Node → Eff (AuthEffects eff) (Either String Node)
removeBodyChild child =
  either (pure ∘ Left) (map Right ∘ DOMNode.removeChild child) =<< getBodyNode

getBodyNode ∷ ∀ eff. Eff (AuthEffects eff) (Either String Node)
getBodyNode =
  toEitherStringNode
    <$> (DOMHTMLDocument.body =<< DOMHTMLWindow.document =<< DOMHTML.window)
  where
  toEitherStringNode =
    maybe
      (Left "Couldn't find body element.")
      Right
      ∘ map DOMHTMLTypes.htmlElementToNode
      ∘ Nullable.toMaybe

getIdToken
  ∷ ∀ eff
  . ProviderR
  → Boolean
  → Aff (AuthEffects eff) (Promise EIdToken)
getIdToken providerR prompt =
  Promise.defer do
    idToken ← if prompt
      then
        getIdTokenUsingPrompt providerR
      else
        getIdTokenUsingLocalStorage providerR
          >>= maybe (getIdTokenSilently providerR) (pure ∘ Right)
    -- Store provider for future local storage gets and reauthentications
    either
      (const $ liftEff $ AuthStore.clearProvider *> AuthStore.clearIdToken)
      (const $ liftEff $ AuthStore.storeProvider $ QAT.Provider providerR)
      idToken
    pure idToken

getIdTokenUsingLocalStorage ∷ ∀ eff. ProviderR → Aff (AuthEffects eff) (Maybe IdToken)
getIdTokenUsingLocalStorage providerR = do
  eitherIdToken ← getUnverifiedIdTokenUsingLocalStorage
  eitherUnhashedNonce ← getUnhashedNonceUsingLocalStorage
  case Tuple eitherIdToken eitherUnhashedNonce of
    Tuple (Right idToken) (Right unhashedNonce) →
      either (const $ Nothing) (if _ then (Just idToken) else Nothing)
        <$> (liftEff $ verify providerR unhashedNonce idToken)
    Tuple _ _ → pure Nothing

getUnverifiedIdTokenUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenUsingLocalStorage =
  flip bind (map IdToken)
    <$> LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

getUnhashedNonceUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String UnhashedNonce)
getUnhashedNonceUsingLocalStorage =
  rmap UnhashedNonce <$> LocalStorage.getLocalStorage AuthKeys.nonceLocalStorageKey

getProviderRUsingLocalStorage ∷ ∀ eff. Eff (AuthEffects eff) (Either String QAT.ProviderR)
getProviderRUsingLocalStorage =
  map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

getIdTokenFromLSOnChange
  ∷ ∀ eff
  . ProviderR
  → UnhashedNonce
  → Aff (AuthEffects eff) EIdToken
getIdTokenFromLSOnChange providerR unhashedNonce =
  getUnverifiedIdTokenFromLSOnChange
    >>= case _ of
          Left localStorageError →
            pure $ Left $ IdTokenUnavailable localStorageError
          Right idToken →
            either
              (Left ∘ IdTokenInvalid ∘ Just )
              (if _ then Right idToken else Left $ IdTokenInvalid Nothing)
              <$> (liftEff $ verify providerR unhashedNonce idToken)

getUnverifiedIdTokenFromLSOnChange
  ∷ ∀ eff
  . Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenFromLSOnChange =
  _.newValue <$> (firstValueFromStallingProducer =<< liftEff getIdTokenStorageEvents)

runParseError ∷ ParseError → String
runParseError (ParseError s) = s

-- TODO: Remove g
verify ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → Eff (AuthEffects eff) (Either Error Boolean)
verify providerR unhashedNonce idToken =
  F.foldl accumulateErrorsAcceptTrues (Right false)
    <$> T.traverse
          (verifyWithJwk providerR unhashedNonce idToken)
          providerR.openIDConfiguration.jwks
  where
  accumulateErrorsAcceptTrues ∷ Either Error Boolean → Either Error Boolean → Either Error Boolean
  accumulateErrorsAcceptTrues =
    case _, _ of
      _, Right true → Right true
      Right true, _ → Right true
      Left acc, Left error →
        Left $ Exception.error $ (Exception.message acc) <> " " <> (Exception.message error)
      Right false, Left error → Left error
      Right false, Right false → Right false
      Left acc, Right false → Left acc

verifyWithJwk ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → JSONWebKey → Eff (AuthEffects eff) (Either Error Boolean)
verifyWithJwk providerR unhashedNonce idToken jwk = do
  OIDCCrypt.verifyIdToken
      (Seconds 1.0)
      idToken
      providerR.openIDConfiguration.issuer
      providerR.clientID
      unhashedNonce
      jwk

getRedirectUri ∷ ∀ eff. Eff (AuthEffects eff) String
getRedirectUri = (_ <> Config.redirectURIString) <$> Browser.locationString

toNotificationOptions ∷ AuthenticationError → Maybe NotificationOptions
toNotificationOptions =
  case _ of
    IdTokenInvalid error →
      Just
        { notification: Notification.Error $ "Sign in failed: Authentication provider provided invalid id token."
        , detail: Notification.Details ∘ Exception.message <$> error
        , timeout
        , actionOptions: Nothing
        }
    IdTokenUnavailable detail →
      Just
      { notification:
          Notification.Error
            $ "Sign in failed: Authentication provider didn't provide a token. This might happen if you are signed into multiple accounts with you authentication provider."
        , detail: Just $ Notification.Details detail
        , timeout
        , actionOptions: Nothing
        }
    PromptDismissed →
      Just
        { notification: Notification.Warning $ "Sign in prompt closed."
        , detail: Nothing
        , timeout
        , actionOptions: Nothing
        }
    ProviderError detail →
      Just
        { notification: Notification.Error $ "Sign in failed: There was a problem with your provider configuration, please update your SlamData configuration and try again."
        , detail: Just $ Notification.Details detail
        , timeout
        , actionOptions: Nothing
        }
    DOMError _ → Nothing
  where
  timeout = Just $ Milliseconds 5000.0