Add mapMaybe

Add mapMaybe

module Data.Array
  ( (!!)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , length
  , elem
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , drop
  , take
  , insertAt
  , deleteAt
  , updateAt
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  ) where

import Data.Maybe
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

(!!) :: forall a. [a] -> Number -> Maybe a
(!!) xs n =
  if n < 0 || n >= (length xs) || isInt n
    then Nothing
    else Just (xs `unsafeIndex` n)
  where
  isInt n = n /= complement (complement n)

foreign import snoc
  "function snoc(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _       = Nothing

last :: forall a. [a] -> Maybe a
last (x : []) = Just x
last (_ : xs) = last xs
last _        = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice 0 (length xs - 1) xs)

null :: forall a. [a] -> Boolean
null [] = true
null _  = false

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import elem
  "function elem(e) {\
  \  return function (l) {\
  \    return l.indexOf(e) !== -1;\
  \  };\
  \}" :: forall a. a -> [a] -> Boolean

foreign import elemIndex
  "function elemIndex (e) {\
  \  return function (l) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. a -> [a] -> Number

foreign import elemLastIndex
  "function elemLastIndex (e) {\
  \  return function (l) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. a -> [a] -> Number

foreign import append
  "function append (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import concat
  "function concat (xss) {\
  \  var result = [];\
  \  for (var i = 0, l = xss.length; i < l; i++) {\
  \    result.push.apply(result, xss[i]);\
  \  }\
  \  return result;\
  \}" :: forall a. [[a]] -> [a]

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

take :: forall a. Number -> [a] -> [a]
take n = slice 0 n

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var i = ~~index;\
  \      if (i < 0 || i >= l.length) return l;\
  \      var l1 = l.slice();\
  \      l1[i] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

foreign import mapMaybe
  "function mapMaybe (f) {\
  \  return function (arr) {\
  \    var l = arr.length, n = 0;\
  \    var result = new Array();\
  \    for (var i = 0; i < l; i++) {\
  \      var x = f(arr[i]);\
  \      if (x.ctor === 'Data.Maybe.Just') {\
  \        result[n++] = x.values[0];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> Maybe b) -> [a] -> [b]

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

foreign import range
  "function range (start) {\
  \  return function (end) {\
  \    var i = ~~start, e = ~~end;\
  \    var step = i > e ? -1 : 1;\
  \    var result = [i], n = 1;\
  \    while (i !== e) {\
  \      i += step;\
  \      result[n++] = i;\
  \    }\
  \    return result;\
  \  };\
  \}" :: Number -> Number -> [Number]

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortJS comp xs
  where
  comp x y = case compare x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = append

module Data.Array
  ( (!!)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , length
  , elem
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , drop
  , take
  , insertAt
  , deleteAt
  , updateAt
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  ) where

import Data.Maybe
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

(!!) :: forall a. [a] -> Number -> Maybe a
(!!) xs n =
  if n < 0 || n >= (length xs) || isInt n
    then Nothing
    else Just (xs `unsafeIndex` n)
  where
  isInt n = n /= complement (complement n)

foreign import snoc
  "function snoc(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _       = Nothing

last :: forall a. [a] -> Maybe a
last (x : []) = Just x
last (_ : xs) = last xs
last _        = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice 0 (length xs - 1) xs)

null :: forall a. [a] -> Boolean
null [] = true
null _  = false

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import elem
  "function elem(e) {\
  \  return function (l) {\
  \    return l.indexOf(e) !== -1;\
  \  };\
  \}" :: forall a. a -> [a] -> Boolean

foreign import elemIndex
  "function elemIndex (e) {\
  \  return function (l) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. a -> [a] -> Number

foreign import elemLastIndex
  "function elemLastIndex (e) {\
  \  return function (l) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. a -> [a] -> Number

foreign import append
  "function append (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import concat
  "function concat (xss) {\
  \  var result = [];\
  \  for (var i = 0, l = xss.length; i < l; i++) {\
  \    result.push.apply(result, xss[i]);\
  \  }\
  \  return result;\
  \}" :: forall a. [[a]] -> [a]

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

take :: forall a. Number -> [a] -> [a]
take n = slice 0 n

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var i = ~~index;\
  \      if (i < 0 || i >= l.length) return l;\
  \      var l1 = l.slice();\
  \      l1[i] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

foreign import range
  "function range (start) {\
  \  return function (end) {\
  \    var i = ~~start, e = ~~end;\
  \    var step = i > e ? -1 : 1;\
  \    var result = [i], n = 1;\
  \    while (i !== e) {\
  \      i += step;\
  \      result[n++] = i;\
  \    }\
  \    return result;\
  \  };\
  \}" :: Number -> Number -> [Number]

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortJS comp xs
  where
  comp x y = case compare x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = append


Fix tests

Fix tests

module Test.Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE())
import Data.Traversable (traverse)
import Node.Buffer (BUFFER, BufferValueType(..), toArray, concat', fromArray, fill, copy, readString, fromString, toString, read, write, create)
import Node.Encoding (Encoding(..))
import Test.Assert (ASSERT, assert')

type Test = forall e. Eff (assert :: ASSERT, buffer :: BUFFER, console :: CONSOLE | e) Unit

main :: Test
main = do
  log "Testing..."

  log "Reading and writing"
  testReadWrite

  log "fromArray"
  testFromArray

  log "toArray"
  testToArray

  log "fromString"
  testFromString

  log "toString"
  testToString

  log "readString"
  testReadString

  log "copy"
  testCopy

  log "fill"
  testFill

  log "concat'"
  testConcat'

testReadWrite :: Test
testReadWrite = do
  buf <- create 1
  let val = 42
  write UInt8 val 0 buf
  readVal <- read UInt8 0 buf

  assertEq val readVal

testFromArray :: Test
testFromArray = do
  buf <- fromArray [1,2,3,4,5]
  readVal <- read UInt8 2 buf

  assertEq 3 readVal

testToArray :: Test
testToArray = do
  let val = [1,2,67,3,3,7,8,3,4,237]

  buf    <- fromArray val
  valOut <- toArray buf

  assertEq val valOut

testFromString :: Test
testFromString = do
  let str = "hello, world"

  buf <- fromString str ASCII
  val <- read UInt8 6 buf

  assertEq val 32 -- ASCII space

testToString :: Test
testToString = do
  let str = "hello, world"

  buf    <- fromString str ASCII
  strOut <- toString ASCII buf

  assertEq str strOut

testReadString :: Test
testReadString = do
  let str = "hello, world"

  buf    <- fromString str ASCII
  strOut <- readString ASCII 7 12 buf

  assertEq "world" strOut

testCopy :: Test
testCopy = do
  buf1 <- fromArray [1,2,3,4,5]
  buf2 <- fromArray [10,9,8,7,6]

  copied <- copy 0 3 buf1 2 buf2
  out    <- toArray buf2

  assertEq copied 3
  assertEq out [10,9,1,2,3]

testFill :: Test
testFill = do
  buf <- fromArray [1,1,1,1,1]
  fill 42 2 4 buf
  out <- toArray buf

  assertEq [1,1,42,42,1] out

testConcat' :: Test
testConcat' = do
  bufs <- traverse fromArray $ map (\x -> [x, x+1, x+2]) [0,3,6,9,12]
  buf  <- concat' bufs 15
  out  <- toArray buf

  assertEq [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14] out

assertEq :: forall a. (Eq a, Show a) => a -> a -> Test
assertEq x y =
  if x == y
    then pure unit
    else let msg = show x <> " and " <> show y <> " were not equal."
         in assert' msg false

module Test.Main where

import Prelude
import Data.Traversable (traverse)
import Control.Monad.Eff
import Control.Monad.Eff.Console (log, CONSOLE())
import Test.Assert

import Node.Buffer
import Node.Encoding

type Test = forall e. Eff (assert :: ASSERT, buffer :: BUFFER, console :: CONSOLE | e) Unit

main :: Test
main = do
  log "Testing..."

  log "Reading and writing"
  testReadWrite

  log "fromArray"
  testFromArray

  log "toArray"
  testToArray

  log "fromString"
  testFromString

  log "toString"
  testToString

  log "readString"
  testReadString

  log "copy"
  testCopy

  log "fill"
  testFill

  log "concat'"
  testConcat'

testReadWrite :: Test
testReadWrite = do
  buf <- create 1
  let val = 42
  write UInt8 val 0 buf
  readVal <- read UInt8 0 buf

  assertEq val readVal

testFromArray :: Test
testFromArray = do
  buf <- fromArray [1,2,3,4,5]
  readVal <- read UInt8 2 buf

  assertEq 3 readVal

testToArray :: Test
testToArray = do
  let val = [1,2,67,3,3,7,8,3,4,237]

  buf    <- fromArray val
  valOut <- toArray buf

  assertEq val valOut

testFromString :: Test
testFromString = do
  let str = "hello, world"

  buf <- fromString str ASCII
  val <- read UInt8 6 buf

  assertEq val 32 -- ASCII space

testToString :: Test
testToString = do
  let str = "hello, world"

  buf    <- fromString str ASCII
  strOut <- toString ASCII buf

  assertEq str strOut

testReadString :: Test
testReadString = do
  let str = "hello, world"

  buf    <- fromString str ASCII
  strOut <- readString ASCII 7 12 buf

  assertEq "world" strOut

testCopy :: Test
testCopy = do
  buf1 <- fromArray [1,2,3,4,5]
  buf2 <- fromArray [10,9,8,7,6]

  copied <- copy 0 3 buf1 2 buf2
  out    <- toArray buf2

  assertEq copied 3
  assertEq out [10,9,1,2,3]

testFill :: Test
testFill = do
  buf <- fromArray [1,1,1,1,1]
  fill 42 2 4 buf
  out <- toArray buf

  assertEq [1,1,42,42,1] out

testConcat' :: Test
testConcat' = do
  bufs <- traverse fromArray $ map (\x -> [x, x+1, x+2]) [0,3,6,9,12]
  buf  <- concat' bufs 15
  out  <- toArray buf

  assertEq [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14] out

assertEq :: forall a. (Eq a, Show a) => a -> a -> Test
assertEq x y =
  if x == y
    then return unit
    else let msg = show x ++ " and " ++ show y ++ " were not equal."
         in assert' msg false


Add Eff variant of unsafeRef

Add Eff variant of unsafeRef

module Web.Firebase.UnsafeRef
  ( refFor,
    unsafeRef
  ) where
import Prelude (($))
import Control.Monad.Aff (Aff())
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Data.Either.Unsafe  (fromRight)
import Data.URI (runParseURI)
import Web.Firebase as FB
import Web.Firebase.Types as FBT

--| Aff version of unsafeRef
refFor :: String -> forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
refFor s = liftEff (unsafeRef s)

-- | Unsafely read a string that might be a reference, and turn it into a firebase reference
-- may throw javascript exceptions, intended to keep test code terse, not meant for production usage
-- This will fail silently if you pass something that is not a url.
unsafeRef :: String -> forall eff. Eff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
unsafeRef s = FB.newFirebase $ fromRight (runParseURI s)

module Web.Firebase.UnsafeRef
  ( refFor
  ) where

import Control.Monad.Aff (Aff())
import Control.Monad.Eff.Class (liftEff)
import Data.Either.Unsafe  (fromRight)
import Data.URI (runParseURI)
import Web.Firebase as FB
import Web.Firebase.Types as FBT

-- | Unsafely read a string that might be a reference, and turn it into a firebase reference
-- may throw javascript exceptions, intended to keep test code terse, not meant for production usage
-- only pass constants to this
refFor :: String -> forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
refFor s = do
  let fbUri = fromRight (runParseURI s)
  liftEff (FB.newFirebase fbUri)


[DAE-6] Cosmetics

[DAE-6] Cosmetics

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error, Error)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST))
import Data.Maybe (Maybe (Just))
import Data.String (split, joinWith)
import Data.Array.Partial (last)
import Network.HTTP.Affjax (affjax, defaultRequest, AJAX, get, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader (ContentType))
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency)
import Daedalus.Constants (backendPrefix)
import Data.MediaType.Common (applicationJSON)
import Partial.Unsafe (unsafePartial)

-- HELPERS

type URLPath = Array String

urlPath :: forall a. URLPath -> URL
urlPath = joinWith "/"

backendApi :: forall a. URLPath -> URL
backendApi path = urlPath $ [backendPrefix, "api"] <> path

-- REQUESTS HELPERS
decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult res = bimap error id $ decodeJson res.response

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
  res <- affjax $ request { url = backendApi urlPath }
  either throwError pure $ decodeResult res

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

-- REQUESTS
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["get_wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["get_wallet", _address addr]

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = getR ["history", _address addr]

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["send", _address addrFrom, _address addrTo, show $ _coin amount]

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["new_wallet"]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["update_transaction", _address addr, _ctxIdValue ctxId]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = postRBody ["update_wallet", _address addr]

-- FIXME: use DELETE method
deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = postR ["delete_wallet", _address addr]

isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["valid_address", dropModuleName $ gShow cCurrency, addr]
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split "."

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error, Error)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST))
import Data.Maybe (Maybe (Just))
import Data.String (split, joinWith)
import Data.Array.Partial (last)
import Network.HTTP.Affjax (affjax, defaultRequest, AJAX, get, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader (ContentType))
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency)
import Daedalus.Constants (backendPrefix)
import Data.MediaType.Common (applicationJSON)
import Partial.Unsafe (unsafePartial)

-- HELPERS

type URLPath = Array String

urlPath :: forall a. URLPath -> URL
urlPath = joinWith "/"

backendApi :: forall a. URLPath -> URL
backendApi path = urlPath $ [backendPrefix, "api"] <> path

-- REQUESTS HELPERS
decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult res = bimap error id $ decodeJson res.response

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
  res <- affjax $ request { url = backendApi urlPath }
  either throwError pure $ decodeResult res

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

-- REQUESTS
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["get_wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["get_wallet", _address addr]

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = getR ["history", _address addr]

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["send", _address addrFrom, _address addrTo, show (_coin amount)]

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["new_wallet"]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["update_transaction", _address addr, _ctxIdValue ctxId]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = postRBody ["update_wallet", _address addr]

-- FIXME: use DELETE method
deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = postR ["delete_wallet", _address addr]

isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["valid_address", dropModuleName (gShow cCurrency), addr]
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split "."


revert decodeResult

revert decodeResult

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError, catchError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Array.Partial (last)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (split, joinWith)
import Network.HTTP.Affjax (AffjaxResponse, affjax, defaultRequest, AJAX, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader(ContentType))
import Network.HTTP.StatusCode (StatusCode(..))
import Partial.Unsafe (unsafePartial)

-- HELPERS

type URLPath = Array String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path

data ApiError
    = HTTPStatusError (AffjaxResponse Json)
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show res.status <> " msg: " <> show res.response
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult res = bimap (error <<< show <<< JSONDecodingError) id $ decodeJson res.response

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
    res <- affjax $ request { url = backendApi urlPath }
    when (isHttpError res.status) $
        throwError <<< error <<< show $ HTTPStatusError res
    either throwError pure $ decodeResult res
  where
    isHttpError (StatusCode c) = c >= 400

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

-- REQUESTS
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["get_wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["get_wallet", _address addr]

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = getR ["history", _address addr]

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["send", _address addrFrom, _address addrTo, show $ _coin amount]

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["new_wallet"]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["update_transaction", _address addr, _ctxIdValue ctxId]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = postRBody ["update_wallet", _address addr]

-- FIXME: use DELETE method
deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = postR ["delete_wallet", _address addr]

isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["valid_address", dropModuleName $ gShow cCurrency, addr]
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split "."

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError, catchError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Array.Partial (last)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (split, joinWith)
import Network.HTTP.Affjax (AffjaxResponse, affjax, defaultRequest, AJAX, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader(ContentType))
import Network.HTTP.StatusCode (StatusCode(..))
import Partial.Unsafe (unsafePartial)

-- HELPERS

type URLPath = Array String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path

data ApiError
    = HTTPStatusError (AffjaxResponse Json)
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show res.status <> " msg: " <> show res.response
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult = either (Left <<< mkJSONError) (bimap mkServerError id) <<< decodeJson <<< _.response
  where
    mkJSONError = error <<< show <<< JSONDecodingError
    mkServerError = error <<< show <<< ServerError

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
    res <- affjax $ request { url = backendApi urlPath }
    when (isHttpError res.status) $
        throwError <<< error <<< show $ HTTPStatusError res
    either throwError pure $ decodeResult res
  where
    isHttpError (StatusCode c) = c >= 400

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

-- REQUESTS
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["get_wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["get_wallet", _address addr]

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = getR ["history", _address addr]

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["send", _address addrFrom, _address addrTo, show $ _coin amount]

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["new_wallet"]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["update_transaction", _address addr, _ctxIdValue ctxId]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = postRBody ["update_wallet", _address addr]

-- FIXME: use DELETE method
deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = postR ["delete_wallet", _address addr]

isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["valid_address", dropModuleName $ gShow cCurrency, addr]
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split "."


Added validation on answer

Added validation on answer

module Flag.App (Event, Country(..), init, foldp, view) where

import Data.Array (length, uncons, head)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax (AJAX)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

type State = { all :: Countries, current :: Array String, correct :: Int, incorrect :: Int }
type Countries = Array Country

data Event = RequestCountries | ReceiveCountries (Tuple Countries (Array String)) | GuessCountry String

newtype Country = Country { name :: String, flag :: String }
derive instance newtypeCountry :: Newtype Country _
instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

init :: State
init = { all: [], current: [], correct: 0, incorrect: 0 }

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX)
foldp (GuessCountry name) state = case (_ == name) <<< maybe "" (_.name <<< unwrap) $ head state.all of
  true -> noEffects state { correct = state.correct + 1 }
  _    -> noEffects state { incorrect = state.incorrect + 1 }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0, incorrect = 0 },
  effects: [ do
    pure $ Just(ReceiveCountries $ Tuple
      [Country { name: "Ecuador", flag: "ecuador.svg" }]
      ["Ecuador", "Slovenia", "Aruba", "Indonesia"]
    )
  ]
}

view :: State → HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all) of
    Just { head } -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ GuessCountry name) $ text name
    Nothing       -> div $ text "..."

module Flag.App (Event, Country(..), init, foldp, view) where

import CSS.Transform (offset)
import Data.Array (length, uncons)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax (AJAX)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

type State = { all :: Countries, current :: Array String, correct :: Int, incorrect :: Int }
type Countries = Array Country

data Event = RequestCountries | ReceiveCountries (Tuple Countries (Array String)) | GuessCountry String

newtype Country = Country { name :: String, flag :: String }
derive instance newtypeCountry :: Newtype Country _
instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

init :: State
init = { all: [], current: [], correct: 0, incorrect: 0 }

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX)
foldp (GuessCountry name) state = noEffects state { correct = state.correct + 1 }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = { state: state { correct = 0, incorrect = 0 }, effects: [ do
  pure $ Just(ReceiveCountries $ Tuple
    [Country { name: "Ecuador", flag: "ecuador.svg" }]
    ["Ecuador", "Slovenia", "Aruba", "Indonesia"]
  )
] }

view :: State → HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all) of
    Just { head } -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ GuessCountry name) $ text name
    Nothing       -> div $ text "..."


Scale x and y independently

Scale x and y independently

module Main where

import Data.Traversable (for)

import Control.Monad.Eff
import Control.Monad.Eff.DOM
import Control.Monad.Eff.Ref

import Graphics.Canvas

import Debug.Trace

render :: forall eff. Number -> Context2D -> Eff (canvas :: Canvas | eff) Context2D
render count ctx = do
  setFillStyle "#FFFFFF" ctx

  fillPath ctx $ rect ctx
    { x: 0
    , y: 0
    , w: 600
    , h: 600
    }

  setFillStyle "#00FF00" ctx

  withContext ctx $ do
    let scaleX = Math.sin (count * Math.pi / 4) + 1.5
    let scaleY = Math.sin (count * Math.pi / 6) + 1.5

    translate { translateX:  300, translateY:  300 } ctx
    rotate (count * Math.pi / 18) ctx
    scale { scaleX: scaleX, scaleY: scaleY } ctx
    translate { translateX: -100, translateY: -100 } ctx

    fillPath ctx $ rect ctx
      { x: 0
      , y: 0
      , w: 200
      , h: 200
      }

main = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  clickCount <- newRef 0

  render 0 ctx

  node <- querySelector "#canvas"
  for node $ addEventListener "click" $ do
    trace "Mouse clicked!"

    modifyRef clickCount (\count -> count + 1)

    count <- readRef clickCount

    render count ctx

    return unit

module Main where

import Data.Traversable (for)

import Control.Monad.Eff
import Control.Monad.Eff.DOM
import Control.Monad.Eff.Ref

import Graphics.Canvas

import Debug.Trace

render :: forall eff. Number -> Context2D -> Eff (canvas :: Canvas | eff) Context2D
render count ctx = do
  setFillStyle "#FFFFFF" ctx

  fillPath ctx $ rect ctx
    { x: 0
    , y: 0
    , w: 600
    , h: 600
    }

  setFillStyle "#00FF00" ctx

  withContext ctx $ do
    let newScale = Math.sin (count * Math.pi / 4) + 1.5

    translate { translateX:  300, translateY:  300 } ctx
    rotate (count * Math.pi / 18) ctx
    scale { scaleX: newScale, scaleY: newScale } ctx
    translate { translateX: -100, translateY: -100 } ctx

    fillPath ctx $ rect ctx
      { x: 0
      , y: 0
      , w: 200
      , h: 200
      }

main = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  clickCount <- newRef 0

  render 0 ctx

  node <- querySelector "#canvas"
  for node $ addEventListener "click" $ do
    trace "Mouse clicked!"

    modifyRef clickCount (\count -> count + 1)

    count <- readRef clickCount

    render count ctx

    return unit


moved Aff tests into Predicates

moved Aff tests into Predicates

as they are not Aff specific any more

module Test.Spec.AssertionSpec where

import Prelude
import Effect.Exception (error)
import Control.Monad.Error.Class (throwError)
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions as A
import Test.Spec.Assertions.String as AS

assertionSpec :: Spec Unit
assertionSpec =
  describe "Test" $
    describe "Spec" $
      describe "Assertions" do

        describe "String" do
          describe "shouldContain" do
            it "accepts strings that contains substrings" $
              "foobar" `AS.shouldContain` "foo"
            it "rejects strings that does not contain substrings" $
              A.expectError $ "baz" `AS.shouldContain` "foo"

          describe "shouldNotContain" do
            it "accepts strings that does not contain substrings" $
              "foobar" `AS.shouldNotContain` "baz"
            it "rejects strings that contains substrings" $
              A.expectError $ "bazbar" `AS.shouldNotContain` "baz"

          describe "shouldStartWith" do
            it "accepts strings that start with prefix" $
              "hello, world" `AS.shouldStartWith` "hello"
            it "rejects strings that do not start with prefix" $
              A.expectError $ "hello" `AS.shouldStartWith` "hello, world"

          describe "shouldEndWith" do
            it "accepts strings that end with suffix" $
              "hello, world" `AS.shouldEndWith` "world"
            it "rejects strings that do not end with suffix" $
              A.expectError $ "world" `AS.shouldEndWith` "hello, world"

        describe "Predicates" do
          describe "shouldSatisfy" do
            it "accepts values where predicate returns true" $
              3 `A.shouldSatisfy` (_ > 2)
            it "rejects values where predicate returns false" $
              A.expectError $ 3 `A.shouldSatisfy` (_ < 2)

          describe "shouldNotSatisfy" do
            it "accepts values where predicate returns false" $
              3 `A.shouldNotSatisfy` (_ < 2)
            it "rejects values where predicate returns true" $
              A.expectError $ 3 `A.shouldNotSatisfy` (_ > 2)

          let contained = "nono"
              notcontained = "zzz"
              f = pure contained

          describe "expectError" do
            it "returns unit when given an error" $
              A.expectError $ throwError $ error "omg"
            it "returns an error when given a non-error" $
              A.expectError $ A.expectError $ pure "ok"

          describe "shouldReturn" do
            it "accepts that `m String` contains \"nono\"" $
              f `A.shouldReturn` contained
            it "rejects that `m String` contains \"zzz\"" $
              A.expectError $ f `A.shouldReturn` notcontained

          describe "shouldNotReturn" do
            it "accepts f does not contain \"zzz\"" $
              f `A.shouldNotReturn` notcontained
            it "rejects that `m String` does not contain \"zzz\"" $
              A.expectError $ f `A.shouldNotReturn` contained

        describe "Foldable" do
          describe "for some foldable" do
            let f = ["haha", "nono"]
            let contained = "nono"
            let notcontained = "zzz"

            describe "shouldContain" do
              it "accepts f that contains a" $
                f `A.shouldContain` contained
              it "rejects f that does not contain a" $
                A.expectError $ f `A.shouldContain` notcontained

            describe "shouldNotContain" do
              it "accepts f that does not contain a" $
                f `A.shouldNotContain` notcontained
              it "rejects f that contains a" $
                A.expectError $ f `A.shouldNotContain` contained

module Test.Spec.AssertionSpec where

import Prelude
import Effect.Exception (error)
import Control.Monad.Error.Class (throwError)
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions as A
import Test.Spec.Assertions.String as AS

assertionSpec :: Spec Unit
assertionSpec =
  describe "Test" $
    describe "Spec" $
      describe "Assertions" do

        describe "String" do
          describe "shouldContain" do
            it "accepts strings that contains substrings" $
              "foobar" `AS.shouldContain` "foo"
            it "rejects strings that does not contain substrings" $
              A.expectError $ "baz" `AS.shouldContain` "foo"

          describe "shouldNotContain" do
            it "accepts strings that does not contain substrings" $
              "foobar" `AS.shouldNotContain` "baz"
            it "rejects strings that contains substrings" $
              A.expectError $ "bazbar" `AS.shouldNotContain` "baz"

          describe "shouldStartWith" do
            it "accepts strings that start with prefix" $
              "hello, world" `AS.shouldStartWith` "hello"
            it "rejects strings that do not start with prefix" $
              A.expectError $ "hello" `AS.shouldStartWith` "hello, world"

          describe "shouldEndWith" do
            it "accepts strings that end with suffix" $
              "hello, world" `AS.shouldEndWith` "world"
            it "rejects strings that do not end with suffix" $
              A.expectError $ "world" `AS.shouldEndWith` "hello, world"

        describe "Predicates" do
          describe "shouldSatisfy" do
            it "accepts values where predicate returns true" $
              3 `A.shouldSatisfy` (_ > 2)
            it "rejects values where predicate returns false" $
              A.expectError $ 3 `A.shouldSatisfy` (_ < 2)

          describe "shouldNotSatisfy" do
            it "accepts values where predicate returns false" $
              3 `A.shouldNotSatisfy` (_ < 2)
            it "rejects values where predicate returns true" $
              A.expectError $ 3 `A.shouldNotSatisfy` (_ > 2)

        describe "Foldable" do
          describe "for some foldable" do
            let f = ["haha", "nono"]
            let contained = "nono"
            let notcontained = "zzz"

            describe "shouldContain" do
              it "accepts f that contains a" $
                f `A.shouldContain` contained
              it "rejects f that does not contain a" $
                A.expectError $ f `A.shouldContain` notcontained

            describe "shouldNotContain" do
              it "accepts f that does not contain a" $
                f `A.shouldNotContain` notcontained
              it "rejects f that contains a" $
                A.expectError $ f `A.shouldNotContain` contained

        describe "Aff" do
          let contained = "nono"
              notcontained = "zzz"
              f = pure contained

          describe "expectError" do
            it "returns unit when given an error" $
              A.expectError $ throwError $ error "omg"
            it "returns an error when given a non-error" $
              A.expectError $ A.expectError $ pure "ok"

          describe "shouldReturn" do
            it "accepts that `Aff String` contains \"nono\"" $
              f `A.shouldReturn` contained
            it "rejects that `Aff String` contains \"zzz\"" $
              A.expectError $ f `A.shouldReturn` notcontained

          describe "shouldNotReturn" do
            it "accepts f does not contain \"zzz\"" $
              f `A.shouldNotReturn` notcontained
            it "rejects that `Aff String` does not contain \"zzz\"" $
              A.expectError $ f `A.shouldNotReturn` contained


Move important functions first

Move important functions first

-- | This module defines low-level bindings to the Node HTTPS module.

module Node.HTTP.Secure
  ( createServer

  , SSLOptions
  , handshakeTimeout
  , requestCert
  , rejectUnauthorized

  , NPNProtocols
  , npnProtocolsString
  , npnProtocolsBuffer
  , npnProtocolsUint8Array
  , npnProtocolsStringArray
  , npnProtocolsBufferArray
  , npnProtocolsUint8ArrayArray
  , npnProtocols

  , ALPNProtocols
  , alpnProtocolsString
  , alpnProtocolsBuffer
  , alpnProtocolsUint8Array
  , alpnProtocolsStringArray
  , alpnProtocolsBufferArray
  , alpnProtocolsUint8ArrayArray
  , alpnProtocols

  , sessionTimeout
  , ticketKeys

  , PFX
  , pfxString
  , pfxBuffer
  , pfx

  , Key
  , keyString
  , keyBuffer
  , keyStringArray
  , keyBufferArray
  , key

  , passphrase

  , Cert
  , certString
  , certBuffer
  , certStringArray
  , certBufferArray
  , cert

  , CA
  , caString
  , caBuffer
  , caStringArray
  , caBufferArray
  , ca

  , CRL
  , crlString
  , crlBuffer
  , crlStringArray
  , crlBufferArray
  , crl

  , ciphers
  , honorCipherOrder
  , ecdhCurve

  , DHParam
  , dhparamString
  , dhparamBuffer
  , dhparam

  , secureProtocol
  , secureOptions
  , sessionIdContext
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Data.ArrayBuffer.Types (Uint8Array)
import Data.Foreign (Foreign)
import Data.Options (Options, Option, options, opt)
import Node.Buffer (Buffer)
import Node.HTTP (Request, Response, Server, HTTP)
import Unsafe.Coerce (unsafeCoerce)

-- | The type of HTTPS server options
data SSLOptions

-- | Create an HTTPS server, given the SSL options and a function to be executed
-- | when a request is received.
foreign import createServerImpl ::
  forall eff.
  Foreign ->
  (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
  Eff (http :: HTTP | eff) Server

-- | Create an HTTPS server, given the SSL options and a function to be executed
-- | when a request is received.
createServer :: forall eff.
                Options SSLOptions ->
                (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
                Eff (http :: HTTP | eff) Server
createServer = createServerImpl <<< options

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
handshakeTimeout :: Option SSLOptions Int
handshakeTimeout = opt "handshakeTimeout"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
requestCert :: Option SSLOptions Boolean
requestCert = opt "requestCert"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
rejectUnauthorized :: Option SSLOptions Boolean
rejectUnauthorized = opt "rejectUnauthorized"

-- | The npnProtocols option can be a String, a Buffer, a Uint8Array, or an
-- | array of any of those types.
data NPNProtocols
npnProtocolsString :: String -> NPNProtocols
npnProtocolsString = unsafeCoerce
npnProtocolsBuffer :: Buffer -> NPNProtocols
npnProtocolsBuffer = unsafeCoerce
npnProtocolsUint8Array :: Uint8Array -> NPNProtocols
npnProtocolsUint8Array = unsafeCoerce
npnProtocolsStringArray :: Array String -> NPNProtocols
npnProtocolsStringArray = unsafeCoerce
npnProtocolsBufferArray :: Array Buffer -> NPNProtocols
npnProtocolsBufferArray = unsafeCoerce
npnProtocolsUint8ArrayArray :: Array Uint8Array -> NPNProtocols
npnProtocolsUint8ArrayArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
npnProtocols :: Option SSLOptions NPNProtocols
npnProtocols = opt "NPNProtocols"

-- | The alpnProtocols option can be a String, a Buffer, a Uint8Array, or an
-- | array of any of those types.
data ALPNProtocols
alpnProtocolsString :: String -> ALPNProtocols
alpnProtocolsString = unsafeCoerce
alpnProtocolsBuffer :: Buffer -> ALPNProtocols
alpnProtocolsBuffer = unsafeCoerce
alpnProtocolsUint8Array :: Uint8Array -> ALPNProtocols
alpnProtocolsUint8Array = unsafeCoerce
alpnProtocolsStringArray :: Array String -> ALPNProtocols
alpnProtocolsStringArray = unsafeCoerce
alpnProtocolsBufferArray :: Array Buffer -> ALPNProtocols
alpnProtocolsBufferArray = unsafeCoerce
alpnProtocolsUint8ArrayArray :: Array Uint8Array -> ALPNProtocols
alpnProtocolsUint8ArrayArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
alpnProtocols :: Option SSLOptions ALPNProtocols
alpnProtocols = opt "ALPNProtocols"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
sessionTimeout :: Option SSLOptions Int
sessionTimeout = opt "sessionTimeout"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
ticketKeys :: Option SSLOptions Buffer
ticketKeys = opt "ticketKeys"

-- | The PFX option can take either a String or a Buffer
data PFX
pfxString :: String -> PFX
pfxString = unsafeCoerce
pfxBuffer :: Buffer -> PFX
pfxBuffer = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
pfx :: Option SSLOptions PFX
pfx = opt "pfx"

-- | The key option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data Key
keyString :: String -> Key
keyString = unsafeCoerce
keyBuffer :: Buffer -> Key
keyBuffer = unsafeCoerce
keyStringArray :: Array String -> Key
keyStringArray = unsafeCoerce
keyBufferArray :: Array Buffer -> Key
keyBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
key :: Option SSLOptions Key
key = opt "key"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
passphrase :: Option SSLOptions String
passphrase = opt "passphrase"

-- | The cert option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data Cert
certString :: String -> Cert
certString = unsafeCoerce
certBuffer :: Buffer -> Cert
certBuffer = unsafeCoerce
certStringArray :: Array String -> Cert
certStringArray = unsafeCoerce
certBufferArray :: Array Buffer -> Cert
certBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
cert :: Option SSLOptions Cert
cert = opt "cert"

-- | The CA option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data CA
caString :: String -> CA
caString = unsafeCoerce
caBuffer :: Buffer -> CA
caBuffer = unsafeCoerce
caStringArray :: Array String -> CA
caStringArray = unsafeCoerce
caBufferArray :: Array Buffer -> CA
caBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ca :: Option SSLOptions CA
ca = opt "ca"

-- | The CRL option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data CRL
crlString :: String -> CRL
crlString = unsafeCoerce
crlBuffer :: Buffer -> CRL
crlBuffer = unsafeCoerce
crlStringArray :: Array String -> CRL
crlStringArray = unsafeCoerce
crlBufferArray :: Array Buffer -> CRL
crlBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
crl :: Option SSLOptions CRL
crl = opt "crl"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ciphers :: Option SSLOptions String
ciphers = opt "ciphers"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
honorCipherOrder :: Option SSLOptions Boolean
honorCipherOrder = opt "honorCipherOrder"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ecdhCurve :: Option SSLOptions String
ecdhCurve = opt "ecdhCurve"

-- | The DHParam option can take either a String or a Buffer
data DHParam
dhparamString :: String -> DHParam
dhparamString = unsafeCoerce
dhparamBuffer :: Buffer -> DHParam
dhparamBuffer = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
dhparam :: Option SSLOptions DHParam
dhparam = opt "dhparam"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureProtocol :: Option SSLOptions String
secureProtocol = opt "secureProtocol"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureOptions :: Option SSLOptions Int
secureOptions = opt "secureOptions"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
sessionIdContext :: Option SSLOptions String
sessionIdContext = opt "sessionIdContext"

-- | This module defines low-level bindings to the Node HTTPS module.

module Node.HTTP.Secure
  ( createServer

  , SSLOptions
  , handshakeTimeout
  , requestCert
  , rejectUnauthorized

  , NPNProtocols
  , npnProtocolsString
  , npnProtocolsBuffer
  , npnProtocolsUint8Array
  , npnProtocolsStringArray
  , npnProtocolsBufferArray
  , npnProtocolsUint8ArrayArray
  , npnProtocols

  , ALPNProtocols
  , alpnProtocolsString
  , alpnProtocolsBuffer
  , alpnProtocolsUint8Array
  , alpnProtocolsStringArray
  , alpnProtocolsBufferArray
  , alpnProtocolsUint8ArrayArray
  , alpnProtocols

  , sessionTimeout
  , ticketKeys

  , PFX
  , pfxString
  , pfxBuffer
  , pfx

  , Key
  , keyString
  , keyBuffer
  , keyStringArray
  , keyBufferArray
  , key

  , passphrase

  , Cert
  , certString
  , certBuffer
  , certStringArray
  , certBufferArray
  , cert

  , CA
  , caString
  , caBuffer
  , caStringArray
  , caBufferArray
  , ca

  , CRL
  , crlString
  , crlBuffer
  , crlStringArray
  , crlBufferArray
  , crl

  , ciphers
  , honorCipherOrder
  , ecdhCurve

  , DHParam
  , dhparamString
  , dhparamBuffer
  , dhparam

  , secureProtocol
  , secureOptions
  , sessionIdContext
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Data.ArrayBuffer.Types (Uint8Array)
import Data.Foreign (Foreign)
import Data.Options (Options, Option, options, opt)
import Node.Buffer (Buffer)
import Node.HTTP (Request, Response, Server, HTTP)
import Unsafe.Coerce (unsafeCoerce)

-- | The type of HTTPS server options
data SSLOptions

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
handshakeTimeout :: Option SSLOptions Int
handshakeTimeout = opt "handshakeTimeout"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
requestCert :: Option SSLOptions Boolean
requestCert = opt "requestCert"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
rejectUnauthorized :: Option SSLOptions Boolean
rejectUnauthorized = opt "rejectUnauthorized"

-- | The npnProtocols option can be a String, a Buffer, a Uint8Array, or an
-- | array of any of those types.
data NPNProtocols
npnProtocolsString :: String -> NPNProtocols
npnProtocolsString = unsafeCoerce
npnProtocolsBuffer :: Buffer -> NPNProtocols
npnProtocolsBuffer = unsafeCoerce
npnProtocolsUint8Array :: Uint8Array -> NPNProtocols
npnProtocolsUint8Array = unsafeCoerce
npnProtocolsStringArray :: Array String -> NPNProtocols
npnProtocolsStringArray = unsafeCoerce
npnProtocolsBufferArray :: Array Buffer -> NPNProtocols
npnProtocolsBufferArray = unsafeCoerce
npnProtocolsUint8ArrayArray :: Array Uint8Array -> NPNProtocols
npnProtocolsUint8ArrayArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
npnProtocols :: Option SSLOptions NPNProtocols
npnProtocols = opt "NPNProtocols"

-- | The alpnProtocols option can be a String, a Buffer, a Uint8Array, or an
-- | array of any of those types.
data ALPNProtocols
alpnProtocolsString :: String -> ALPNProtocols
alpnProtocolsString = unsafeCoerce
alpnProtocolsBuffer :: Buffer -> ALPNProtocols
alpnProtocolsBuffer = unsafeCoerce
alpnProtocolsUint8Array :: Uint8Array -> ALPNProtocols
alpnProtocolsUint8Array = unsafeCoerce
alpnProtocolsStringArray :: Array String -> ALPNProtocols
alpnProtocolsStringArray = unsafeCoerce
alpnProtocolsBufferArray :: Array Buffer -> ALPNProtocols
alpnProtocolsBufferArray = unsafeCoerce
alpnProtocolsUint8ArrayArray :: Array Uint8Array -> ALPNProtocols
alpnProtocolsUint8ArrayArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
alpnProtocols :: Option SSLOptions ALPNProtocols
alpnProtocols = opt "ALPNProtocols"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
sessionTimeout :: Option SSLOptions Int
sessionTimeout = opt "sessionTimeout"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
ticketKeys :: Option SSLOptions Buffer
ticketKeys = opt "ticketKeys"

-- | The PFX option can take either a String or a Buffer
data PFX
pfxString :: String -> PFX
pfxString = unsafeCoerce
pfxBuffer :: Buffer -> PFX
pfxBuffer = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
pfx :: Option SSLOptions PFX
pfx = opt "pfx"

-- | The key option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data Key
keyString :: String -> Key
keyString = unsafeCoerce
keyBuffer :: Buffer -> Key
keyBuffer = unsafeCoerce
keyStringArray :: Array String -> Key
keyStringArray = unsafeCoerce
keyBufferArray :: Array Buffer -> Key
keyBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
key :: Option SSLOptions Key
key = opt "key"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
passphrase :: Option SSLOptions String
passphrase = opt "passphrase"

-- | The cert option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data Cert
certString :: String -> Cert
certString = unsafeCoerce
certBuffer :: Buffer -> Cert
certBuffer = unsafeCoerce
certStringArray :: Array String -> Cert
certStringArray = unsafeCoerce
certBufferArray :: Array Buffer -> Cert
certBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
cert :: Option SSLOptions Cert
cert = opt "cert"

-- | The CA option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data CA
caString :: String -> CA
caString = unsafeCoerce
caBuffer :: Buffer -> CA
caBuffer = unsafeCoerce
caStringArray :: Array String -> CA
caStringArray = unsafeCoerce
caBufferArray :: Array Buffer -> CA
caBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ca :: Option SSLOptions CA
ca = opt "ca"

-- | The CRL option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data CRL
crlString :: String -> CRL
crlString = unsafeCoerce
crlBuffer :: Buffer -> CRL
crlBuffer = unsafeCoerce
crlStringArray :: Array String -> CRL
crlStringArray = unsafeCoerce
crlBufferArray :: Array Buffer -> CRL
crlBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
crl :: Option SSLOptions CRL
crl = opt "crl"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ciphers :: Option SSLOptions String
ciphers = opt "ciphers"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
honorCipherOrder :: Option SSLOptions Boolean
honorCipherOrder = opt "honorCipherOrder"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ecdhCurve :: Option SSLOptions String
ecdhCurve = opt "ecdhCurve"

-- | The DHParam option can take either a String or a Buffer
data DHParam
dhparamString :: String -> DHParam
dhparamString = unsafeCoerce
dhparamBuffer :: Buffer -> DHParam
dhparamBuffer = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
dhparam :: Option SSLOptions DHParam
dhparam = opt "dhparam"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureProtocol :: Option SSLOptions String
secureProtocol = opt "secureProtocol"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureOptions :: Option SSLOptions Int
secureOptions = opt "secureOptions"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
sessionIdContext :: Option SSLOptions String
sessionIdContext = opt "sessionIdContext"

-- | Create an HTTPS server, given the SSL options and a function to be executed
-- | when a request is received.
foreign import createServerImpl ::
  forall eff.
  Foreign ->
  (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
  Eff (http :: HTTP | eff) Server

-- | Create an HTTPS server, given the SSL options and a function to be executed
-- | when a request is received.
createServer :: forall eff.
                Options SSLOptions ->
                (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
                Eff (http :: HTTP | eff) Server
createServer = createServerImpl <<< options


Use singleton instead of \x -> [x]

Use singleton instead of \x -> [x]

-- | This module defines functions for rendering Markdown to HTML.

module Text.Markdown.SlamDown.Html
  ( SlamDownEvent()
  , SlamDownState(..)
  , FormFieldValue(..)
  , initSlamDownState
  , applySlamDownEvent
  , renderHalogen
  )
  where

import Prelude
import Control.Alternative (Alternative)
import Control.Monad.State (State(), evalState)
import Control.Monad.State.Class (get, modify)

import Data.Maybe (Maybe(..), maybe)
import Data.List (List(..), mapMaybe, fromList, zipWithA, zip, singleton)
import Data.Monoid (mempty)
import Data.String (joinWith)
import Data.Tuple (Tuple(..))
import Data.Traversable (traverse)
import qualified Data.Validation as V

import Text.Markdown.SlamDown
import Text.Markdown.SlamDown.Parser.Inline (validateFormField, validateTextOfType)

import qualified Data.Array as Array
import qualified Data.Set as S
import qualified Data.StrMap as M
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E

data FormFieldValue
  = SingleValue TextBoxType String
  | MultipleValues (S.Set String)

instance showFormFieldValue :: Show FormFieldValue where
  show (SingleValue t s) = "(SingleValue " ++ show t ++ " " ++ show s ++ ")"
  show (MultipleValues ss) = "(MultipleValues " ++ show ss ++ ")"

-- | The state of a SlamDown form - a mapping from input keys to values
newtype SlamDownState = SlamDownState (M.StrMap FormFieldValue)

instance showSlamDownState :: Show SlamDownState where
  show (SlamDownState m) = "(SlamDownState " ++ show m ++ ")"

-- | The initial state of form, in which all fields use their default values
initSlamDownState :: SlamDown -> SlamDownState
initSlamDownState = SlamDownState <<< M.fromList <<< everything (const mempty) go
  where
  go :: Inline -> List (Tuple String FormFieldValue)
  go (FormField label _ field) =
    maybe mempty (singleton <<< Tuple label) $
      V.runV (const Nothing) Just (validateFormField field) >>= getDefaultValue
  go _ = mempty

  getDefaultValue :: FormField -> Maybe FormFieldValue
  getDefaultValue (TextBox tbt (Just (Literal value))) = Just $ SingleValue tbt value
  getDefaultValue (CheckBoxes (Literal sels) (Literal vals)) = Just $ MultipleValues $ S.fromList $ chk `mapMaybe` zip sels vals
    where
    chk (Tuple true value) = Just value
    chk _ = Nothing
  getDefaultValue (RadioButtons (Literal value) _) = Just $ SingleValue PlainText value
  getDefaultValue (DropDown _ (Just (Literal value))) = Just $ SingleValue PlainText value
  getDefaultValue _ = Nothing

-- | The type of events which can be raised by SlamDown forms
data SlamDownEvent
  = TextChanged TextBoxType String String
  | CheckBoxChanged String String Boolean

-- | Apply a `SlamDownEvent` to a `SlamDownState`.
applySlamDownEvent :: SlamDownState -> SlamDownEvent -> SlamDownState
applySlamDownEvent (SlamDownState m) (TextChanged t key val) =
  SlamDownState (M.insert key (SingleValue t val) m)
applySlamDownEvent (SlamDownState m) (CheckBoxChanged key val checked) =
  SlamDownState (M.alter (Just <<< updateSet) key m)
  where
  updateSet :: Maybe FormFieldValue -> FormFieldValue
  updateSet (Just (MultipleValues s))
    | checked = MultipleValues (S.insert val s)
    | otherwise = MultipleValues (S.delete val s)
  updateSet _
    | checked = MultipleValues (S.singleton val)
    | otherwise = MultipleValues S.empty

type Fresh = State Int

-- | Render the SlamDown AST to an arbitrary Halogen HTML representation
renderHalogen :: forall f. (Alternative f) => String -> SlamDownState -> SlamDown -> Array (H.HTML (f SlamDownEvent))
renderHalogen formName (SlamDownState m) (SlamDown bs) = evalState (traverse renderBlock (fromList bs)) 1

  where

  renderBlock :: Block -> Fresh (H.HTML (f SlamDownEvent))
  renderBlock (Paragraph is) = H.p_ <$> traverse renderInline (fromList is)
  renderBlock (Header level is) = h_ level <$> traverse renderInline (fromList is)
    where
    h_ :: forall a. Int -> Array (H.HTML (f a)) -> H.HTML (f a)
    h_ 1 = H.h1_
    h_ 2 = H.h2_
    h_ 3 = H.h3_
    h_ 4 = H.h4_
    h_ 5 = H.h5_
    h_ 6 = H.h6_
  renderBlock (Blockquote bs) = H.blockquote_ <$> traverse renderBlock (fromList bs)
  renderBlock (Lst lt bss) = el_ lt <$> traverse item (fromList bss)
    where
    el_ :: forall a. ListType -> Array (H.HTML (f a)) -> H.HTML (f a)
    el_ (Bullet _)  = H.ul_
    el_ (Ordered _) = H.ol_
    item :: List Block -> Fresh (H.HTML (f SlamDownEvent))
    item bs = H.li_ <$> traverse renderBlock (fromList bs)
  renderBlock (CodeBlock _ ss) =
    pure $ H.pre_ [ H.code_ [ H.text (joinWith "\n" $ fromList ss) ] ]
  renderBlock (LinkReference l url) =
    pure $ H.p_ [ H.text (l <> ": ")
                , H.a [ A.name l, A.id_ l, A.href url ] [ H.text url ]
                ]
  renderBlock Rule = pure $ H.hr_ []

  renderInline :: Inline -> Fresh (H.HTML (f SlamDownEvent))
  renderInline (Str s) = pure $ H.text s
  renderInline (Entity s) = pure $ H.text s
  renderInline Space = pure $ H.text " "
  renderInline SoftBreak = pure $ H.text "\n"
  renderInline LineBreak = pure $ H.br_ []
  renderInline (Emph is) = H.em_ <$> traverse renderInline (fromList is)
  renderInline (Strong is) = H.strong_ <$> traverse renderInline (fromList is)
  renderInline (Code _ c) = pure $ H.code_ [ H.text c ]
  renderInline (Link body tgt) = H.a [ A.href (href tgt) ] <$> traverse renderInline (fromList body)
    where
    href (InlineLink url) = url
    href (ReferenceLink tgt) = maybe "" ("#" ++) tgt
  renderInline (Image body url) = H.img [ A.src url ] <$> traverse renderInline (fromList body)
  renderInline (FormField label req el) = do
    id <- fresh
    el' <- renderFormElement id label (ensureValidField el)
    pure $ H.span [ A.class_ (A.className "slamdown-field") ]
                  [ H.label (if requiresId then [ A.for id ] else [])
                            [ H.text (label ++ requiredLabel) ]
                  , el'
                  ]
    where
    requiredLabel = if req then "*" else ""
    requiresId = case el of
      CheckBoxes _ _ -> false
      RadioButtons _ _ -> false
      _ -> true

  -- | Make sure that the default value of a form field is valid, and if it is not, strip it out.
  ensureValidField :: FormField -> FormField
  ensureValidField field =
    V.runV
      (const $ stripDefaultValue field)
      id
      (validateFormField field)
    where
      stripDefaultValue :: FormField -> FormField
      stripDefaultValue field =
        case field of
           TextBox t _ -> TextBox t Nothing
           DropDown ls _ -> DropDown ls Nothing
           _ -> field

  renderFormElement :: String -> String -> FormField -> Fresh (H.HTML (f SlamDownEvent))
  renderFormElement id label (TextBox t Nothing) =
    pure $ renderTextInput id label t (lookupTextValue label Nothing)
  renderFormElement id label (TextBox t (Just (Literal value))) =
    pure $ renderTextInput id label t (lookupTextValue label (Just value))
  renderFormElement _ label (RadioButtons (Literal def) (Literal ls)) =
    H.ul [ A.class_ (A.className "slamdown-radios") ] <$> traverse (\val -> radio (Just val == sel) val) (fromList (Cons def ls))
    where
    sel = lookupTextValue label (Just def)
    radio checked value = do
      id <- fresh
      pure $ H.li_ [ H.input [ A.checked checked
                             , A.type_ "radio"
                             , A.id_ id
                             , A.name label
                             , A.value value
                             , E.onChange (E.input_ (TextChanged PlainText label value))
                             ] []
                   , H.label [ A.for id ] [ H.text value ]
                   ]
  renderFormElement _ label (CheckBoxes (Literal bs) (Literal ls)) =
    H.ul [ A.class_ (A.className "slamdown-checkboxes") ] <$> (fromList <$> (zipWithA checkBox (lookupMultipleValues label bs ls) ls))
    where
    checkBox checked value = do
      id <- fresh
      pure $ H.li_ [ H.input [ A.checked checked
                             , A.type_ "checkbox"
                             , A.id_ id
                             , A.name label
                             , A.value value
                             , E.onChecked (E.input (CheckBoxChanged label value))
                             ] []
                   , H.label [ A.for id ] [ H.text value ]
                   ]
  renderFormElement id label (DropDown (Literal ls) Nothing) = do
    pure $ renderDropDown id label (Cons "" ls) Nothing
  renderFormElement id label (DropDown (Literal ls) (Just (Literal sel))) = do
    pure $ renderDropDown id label ls (lookupTextValue label (Just sel))
  renderFormElement _ _ _ = pure $ unsupportedFormElement

  lookupTextValue :: String -> Maybe String -> Maybe String
  lookupTextValue key def =
    case M.lookup key m of
      Just (SingleValue _ val) -> Just val
      _ -> def

  lookupMultipleValues :: String -> List Boolean -> List String -> List Boolean
  lookupMultipleValues key def ls =
    case M.lookup key m of
      Just (MultipleValues val) -> (`S.member` val) <$> ls
      _ -> def

  fresh :: Fresh String
  fresh = do
    n <- get :: Fresh Int
    modify (+ 1)
    pure (formName ++ "-" ++ show n)

renderTextInput :: forall f. (Alternative f) => String -> String -> TextBoxType -> Maybe String -> H.HTML (f SlamDownEvent)
renderTextInput id label t value =
  H.input ([ A.type_ (textBoxTypeName t)
          , A.id_ id
          , A.name label
          , E.onInput (E.input (TextChanged t label))
          ] <> maybe [] (Array.singleton <<< A.value) value) []

renderDropDown :: forall f. (Alternative f) => String -> String -> List String -> Maybe String -> H.HTML (f SlamDownEvent)
renderDropDown id label ls sel =
  H.select [ A.id_ id
           , A.name label
           , E.onValueChanged (E.input (TextChanged PlainText label))
           ]
           (fromList $ maybe option option' sel <$> ls)
  where
  option :: String -> H.HTML (f SlamDownEvent)
  option value = H.option [ A.value value ] [ H.text value ]
  option' :: String -> String -> H.HTML (f SlamDownEvent)
  option' sel value = H.option [ A.selected (value == sel), A.value value ] [ H.text value ]

textBoxTypeName :: TextBoxType -> String
textBoxTypeName t = case t of
  PlainText -> "text"
  Date -> "date"
  Time -> "time"
  DateTime -> "datetime-local"
  Numeric -> "number"

unsupportedFormElement :: forall a. H.HTML a
unsupportedFormElement = H.text "Unsupported form element"

-- | This module defines functions for rendering Markdown to HTML.

module Text.Markdown.SlamDown.Html
  ( SlamDownEvent()
  , SlamDownState(..)
  , FormFieldValue(..)
  , initSlamDownState
  , applySlamDownEvent
  , renderHalogen
  )
  where

import Prelude
import Control.Alternative (Alternative)
import Control.Monad.State (State(), evalState)
import Control.Monad.State.Class (get, modify)

import Data.Maybe (Maybe(..), maybe)
import Data.List (List(..), mapMaybe, fromList, zipWithA, zip, singleton)
import Data.Monoid (mempty)
import Data.String (joinWith)
import Data.Tuple (Tuple(..))
import Data.Traversable (traverse)
import qualified Data.Validation as V

import Text.Markdown.SlamDown
import Text.Markdown.SlamDown.Parser.Inline (validateFormField, validateTextOfType)

import qualified Data.Set as S
import qualified Data.StrMap as M
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E

data FormFieldValue
  = SingleValue TextBoxType String
  | MultipleValues (S.Set String)

instance showFormFieldValue :: Show FormFieldValue where
  show (SingleValue t s) = "(SingleValue " ++ show t ++ " " ++ show s ++ ")"
  show (MultipleValues ss) = "(MultipleValues " ++ show ss ++ ")"

-- | The state of a SlamDown form - a mapping from input keys to values
newtype SlamDownState = SlamDownState (M.StrMap FormFieldValue)

instance showSlamDownState :: Show SlamDownState where
  show (SlamDownState m) = "(SlamDownState " ++ show m ++ ")"

-- | The initial state of form, in which all fields use their default values
initSlamDownState :: SlamDown -> SlamDownState
initSlamDownState = SlamDownState <<< M.fromList <<< everything (const mempty) go
  where
  go :: Inline -> List (Tuple String FormFieldValue)
  go (FormField label _ field) =
    maybe mempty (singleton <<< Tuple label) $
      V.runV (const Nothing) Just (validateFormField field) >>= getDefaultValue
  go _ = mempty

  getDefaultValue :: FormField -> Maybe FormFieldValue
  getDefaultValue (TextBox tbt (Just (Literal value))) = Just $ SingleValue tbt value
  getDefaultValue (CheckBoxes (Literal sels) (Literal vals)) = Just $ MultipleValues $ S.fromList $ chk `mapMaybe` zip sels vals
    where
    chk (Tuple true value) = Just value
    chk _ = Nothing
  getDefaultValue (RadioButtons (Literal value) _) = Just $ SingleValue PlainText value
  getDefaultValue (DropDown _ (Just (Literal value))) = Just $ SingleValue PlainText value
  getDefaultValue _ = Nothing

-- | The type of events which can be raised by SlamDown forms
data SlamDownEvent
  = TextChanged TextBoxType String String
  | CheckBoxChanged String String Boolean

-- | Apply a `SlamDownEvent` to a `SlamDownState`.
applySlamDownEvent :: SlamDownState -> SlamDownEvent -> SlamDownState
applySlamDownEvent (SlamDownState m) (TextChanged t key val) =
  SlamDownState (M.insert key (SingleValue t val) m)
applySlamDownEvent (SlamDownState m) (CheckBoxChanged key val checked) =
  SlamDownState (M.alter (Just <<< updateSet) key m)
  where
  updateSet :: Maybe FormFieldValue -> FormFieldValue
  updateSet (Just (MultipleValues s))
    | checked = MultipleValues (S.insert val s)
    | otherwise = MultipleValues (S.delete val s)
  updateSet _
    | checked = MultipleValues (S.singleton val)
    | otherwise = MultipleValues S.empty

type Fresh = State Int

-- | Render the SlamDown AST to an arbitrary Halogen HTML representation
renderHalogen :: forall f. (Alternative f) => String -> SlamDownState -> SlamDown -> Array (H.HTML (f SlamDownEvent))
renderHalogen formName (SlamDownState m) (SlamDown bs) = evalState (traverse renderBlock (fromList bs)) 1

  where

  renderBlock :: Block -> Fresh (H.HTML (f SlamDownEvent))
  renderBlock (Paragraph is) = H.p_ <$> traverse renderInline (fromList is)
  renderBlock (Header level is) = h_ level <$> traverse renderInline (fromList is)
    where
    h_ :: forall a. Int -> Array (H.HTML (f a)) -> H.HTML (f a)
    h_ 1 = H.h1_
    h_ 2 = H.h2_
    h_ 3 = H.h3_
    h_ 4 = H.h4_
    h_ 5 = H.h5_
    h_ 6 = H.h6_
  renderBlock (Blockquote bs) = H.blockquote_ <$> traverse renderBlock (fromList bs)
  renderBlock (Lst lt bss) = el_ lt <$> traverse item (fromList bss)
    where
    el_ :: forall a. ListType -> Array (H.HTML (f a)) -> H.HTML (f a)
    el_ (Bullet _)  = H.ul_
    el_ (Ordered _) = H.ol_
    item :: List Block -> Fresh (H.HTML (f SlamDownEvent))
    item bs = H.li_ <$> traverse renderBlock (fromList bs)
  renderBlock (CodeBlock _ ss) =
    pure $ H.pre_ [ H.code_ [ H.text (joinWith "\n" $ fromList ss) ] ]
  renderBlock (LinkReference l url) =
    pure $ H.p_ [ H.text (l <> ": ")
                , H.a [ A.name l, A.id_ l, A.href url ] [ H.text url ]
                ]
  renderBlock Rule = pure $ H.hr_ []

  renderInline :: Inline -> Fresh (H.HTML (f SlamDownEvent))
  renderInline (Str s) = pure $ H.text s
  renderInline (Entity s) = pure $ H.text s
  renderInline Space = pure $ H.text " "
  renderInline SoftBreak = pure $ H.text "\n"
  renderInline LineBreak = pure $ H.br_ []
  renderInline (Emph is) = H.em_ <$> traverse renderInline (fromList is)
  renderInline (Strong is) = H.strong_ <$> traverse renderInline (fromList is)
  renderInline (Code _ c) = pure $ H.code_ [ H.text c ]
  renderInline (Link body tgt) = H.a [ A.href (href tgt) ] <$> traverse renderInline (fromList body)
    where
    href (InlineLink url) = url
    href (ReferenceLink tgt) = maybe "" ("#" ++) tgt
  renderInline (Image body url) = H.img [ A.src url ] <$> traverse renderInline (fromList body)
  renderInline (FormField label req el) = do
    id <- fresh
    el' <- renderFormElement id label (ensureValidField el)
    pure $ H.span [ A.class_ (A.className "slamdown-field") ]
                  [ H.label (if requiresId then [ A.for id ] else [])
                            [ H.text (label ++ requiredLabel) ]
                  , el'
                  ]
    where
    requiredLabel = if req then "*" else ""
    requiresId = case el of
      CheckBoxes _ _ -> false
      RadioButtons _ _ -> false
      _ -> true

  -- | Make sure that the default value of a form field is valid, and if it is not, strip it out.
  ensureValidField :: FormField -> FormField
  ensureValidField field =
    V.runV
      (const $ stripDefaultValue field)
      id
      (validateFormField field)
    where
      stripDefaultValue :: FormField -> FormField
      stripDefaultValue field =
        case field of
           TextBox t _ -> TextBox t Nothing
           DropDown ls _ -> DropDown ls Nothing
           _ -> field

  renderFormElement :: String -> String -> FormField -> Fresh (H.HTML (f SlamDownEvent))
  renderFormElement id label (TextBox t Nothing) =
    pure $ renderTextInput id label t (lookupTextValue label Nothing)
  renderFormElement id label (TextBox t (Just (Literal value))) =
    pure $ renderTextInput id label t (lookupTextValue label (Just value))
  renderFormElement _ label (RadioButtons (Literal def) (Literal ls)) =
    H.ul [ A.class_ (A.className "slamdown-radios") ] <$> traverse (\val -> radio (Just val == sel) val) (fromList (Cons def ls))
    where
    sel = lookupTextValue label (Just def)
    radio checked value = do
      id <- fresh
      pure $ H.li_ [ H.input [ A.checked checked
                             , A.type_ "radio"
                             , A.id_ id
                             , A.name label
                             , A.value value
                             , E.onChange (E.input_ (TextChanged PlainText label value))
                             ] []
                   , H.label [ A.for id ] [ H.text value ]
                   ]
  renderFormElement _ label (CheckBoxes (Literal bs) (Literal ls)) =
    H.ul [ A.class_ (A.className "slamdown-checkboxes") ] <$> (fromList <$> (zipWithA checkBox (lookupMultipleValues label bs ls) ls))
    where
    checkBox checked value = do
      id <- fresh
      pure $ H.li_ [ H.input [ A.checked checked
                             , A.type_ "checkbox"
                             , A.id_ id
                             , A.name label
                             , A.value value
                             , E.onChecked (E.input (CheckBoxChanged label value))
                             ] []
                   , H.label [ A.for id ] [ H.text value ]
                   ]
  renderFormElement id label (DropDown (Literal ls) Nothing) = do
    pure $ renderDropDown id label (Cons "" ls) Nothing
  renderFormElement id label (DropDown (Literal ls) (Just (Literal sel))) = do
    pure $ renderDropDown id label ls (lookupTextValue label (Just sel))
  renderFormElement _ _ _ = pure $ unsupportedFormElement

  lookupTextValue :: String -> Maybe String -> Maybe String
  lookupTextValue key def =
    case M.lookup key m of
      Just (SingleValue _ val) -> Just val
      _ -> def

  lookupMultipleValues :: String -> List Boolean -> List String -> List Boolean
  lookupMultipleValues key def ls =
    case M.lookup key m of
      Just (MultipleValues val) -> (`S.member` val) <$> ls
      _ -> def

  fresh :: Fresh String
  fresh = do
    n <- get :: Fresh Int
    modify (+ 1)
    pure (formName ++ "-" ++ show n)

renderTextInput :: forall f. (Alternative f) => String -> String -> TextBoxType -> Maybe String -> H.HTML (f SlamDownEvent)
renderTextInput id label t value =
  H.input ([ A.type_ (textBoxTypeName t)
          , A.id_ id
          , A.name label
          , E.onInput (E.input (TextChanged t label))
          ] <> maybe [] ((\x -> [x]) <<< A.value) value) []

renderDropDown :: forall f. (Alternative f) => String -> String -> List String -> Maybe String -> H.HTML (f SlamDownEvent)
renderDropDown id label ls sel =
  H.select [ A.id_ id
           , A.name label
           , E.onValueChanged (E.input (TextChanged PlainText label))
           ]
           (fromList $ maybe option option' sel <$> ls)
  where
  option :: String -> H.HTML (f SlamDownEvent)
  option value = H.option [ A.value value ] [ H.text value ]
  option' :: String -> String -> H.HTML (f SlamDownEvent)
  option' sel value = H.option [ A.selected (value == sel), A.value value ] [ H.text value ]

textBoxTypeName :: TextBoxType -> String
textBoxTypeName t = case t of
  PlainText -> "text"
  Date -> "date"
  Time -> "time"
  DateTime -> "datetime-local"
  Numeric -> "number"

unsupportedFormElement :: forall a. H.HTML a
unsupportedFormElement = H.text "Unsupported form element"