use itemized duration

use itemized duration

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, diff, modifyTime, setHour, setMinute, setSecond, setMillisecond, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum, toEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Formatter.Number (Formatter(..), format)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Hours(..), Milliseconds(..), Minutes(..), Seconds(..))
import Data.Tuple (Tuple(..))

weekendStartDayOfWeek :: Int
weekendStartDayOfWeek = 5

weekendStartHour :: Int
weekendStartHour = 17

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe String)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend now =
    let dayOfWeek = fromEnum $ weekday $ date now
        dayDiff   = Days $ toNumber (weekendStartDayOfWeek - dayOfWeek)
        startDate = fromMaybe bottom $ adjust dayDiff now
        startDatetime = modifyTime ((setHour $ fromMaybe bottom $ toEnum weekendStartHour) >>> (setMinute $ fromMaybe bottom $ toEnum 0) >>> (setSecond $ fromMaybe bottom $ toEnum 0) >>> (setMillisecond $ fromMaybe bottom $ toEnum 0)) startDate
     in if startDatetime < now
        then Nothing
        else let timeFormatter = Formatter { comma: false, before: 2, after: 0, abbreviations: false, sign: false }
                 difference :: ItemizedDuration
                 difference = diff startDatetime now
              in case difference of
                (Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)) ->
                  let dd = show $ floor d
                      hh = format timeFormatter h
                      mm = format timeFormatter m
                      ss = format timeFormatter s
                  in Just $ (if d > 0.0 then dd <> " days and " else "") <> hh <> ":" <> mm <> ":" <> ss

msInSecond :: Number
msInSecond = 1000.0
msInMinute :: Number
msInMinute = 60.0 * msInSecond
msInHour :: Number
msInHour = 60.0 * msInMinute
msInDay :: Number
msInDay = 24.0 * msInHour

data ItemizedDuration = Itemized Days Hours Minutes Seconds Milliseconds

instance durationItemized :: Duration ItemizedDuration where
  fromDuration (Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)) =
    Milliseconds (d * msInDay + h * msInHour + m * msInMinute + s * msInSecond + ms)
  toDuration (Milliseconds ms') = Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)
    where divMod x y = Tuple (div x y) (mod x y)
          Tuple s' ms = divMod ms' 1000.0
          Tuple m' s  = divMod s' 60.0
          Tuple h' m  = divMod m' 60.0
          Tuple d  h  = divMod h' 24.0

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, diff, modifyTime, setHour, setMinute, setSecond, setMillisecond, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum, toEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Formatter.Number (Formatter(..), format)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Newtype (unwrap)
import Data.Time.Duration (class Duration, Days(..), Hours(..), Milliseconds(..), Minutes(..), Seconds(..), convertDuration)
import Data.Tuple (Tuple(..))

weekendStartDayOfWeek :: Int
weekendStartDayOfWeek = 5

weekendStartHour :: Int
weekendStartHour = 17

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe String)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend now =
    let dayOfWeek = fromEnum $ weekday $ date now
        dayDiff   = Days $ toNumber (weekendStartDayOfWeek - dayOfWeek)
        startDate = fromMaybe bottom $ adjust dayDiff now
        startDatetime = modifyTime ((setHour $ fromMaybe bottom $ toEnum weekendStartHour) >>> (setMinute $ fromMaybe bottom $ toEnum 0) >>> (setSecond $ fromMaybe bottom $ toEnum 0) >>> (setMillisecond $ fromMaybe bottom $ toEnum 0)) startDate
        timeFormatter = Formatter { comma: false, before: 2, after: 0, abbreviations: false, sign: false }
        millisFormatter = Formatter { comma: false, before: 3, after: 0, abbreviations: false, sign: false }
        diffMillis :: ItemizedDuration
        diffMillis = diff startDatetime now
    in if startDatetime < now
       then Nothing
       else Just let d :: Days
                     d  = convertDuration diffMillis
                     d' = floor $ unwrap d
                     dd = show d'
                     h :: Hours
                     h  = convertDuration $ d - (Days $ toNumber d')
                     h' = toNumber $ floor $ unwrap h
                     hh = format timeFormatter h'
                     m :: Minutes
                     m  = convertDuration $ h - (Hours h')
                     m' = toNumber $ floor $ unwrap m
                     mm = format timeFormatter m'
                     s :: Seconds
                     s  = convertDuration $ m - (Minutes m')
                     s' = toNumber $ floor $ unwrap s
                     ss = format timeFormatter s'
                 in (if d' > 0 then dd <> " days and " else "") <> hh <> ":" <> mm <> ":" <> ss

msInSecond :: Number
msInSecond = 1000.0
msInMinute :: Number
msInMinute = 60.0 * msInSecond
msInHour :: Number
msInHour = 60.0 * msInMinute
msInDay :: Number
msInDay = 24.0 * msInHour

data ItemizedDuration = Itemized Days Hours Minutes Seconds Milliseconds

instance durationItemized :: Duration ItemizedDuration where
  fromDuration (Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)) =
    Milliseconds (d * msInDay + h * msInHour + m * msInMinute + s * msInSecond + ms)
  toDuration (Milliseconds ms') = Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)
    where divMod x y = Tuple (div x y) (mod x y)
          (Tuple s' ms) = divMod ms' 1000.0
          (Tuple m' s)  = divMod s' 60.0
          (Tuple h' m)  = divMod m' 60.0
          (Tuple d  h)  = divMod h' 24.0


Update docs for `guard` (#36)

Update docs for `guard` (#36)

* Update docs for guard

* add imports to guard docs

* remove additional description

module Control.MonadZero
  ( class MonadZero
  , guard
  , module Control.Alt
  , module Control.Alternative
  , module Control.Applicative
  , module Control.Apply
  , module Control.Bind
  , module Control.Monad
  , module Control.Plus
  , module Data.Functor
  ) where

import Control.Alt (class Alt, alt, (<|>))
import Control.Alternative (class Alternative)
import Control.Applicative (class Applicative, pure, liftA1, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))
import Control.Monad (class Monad, ap, liftM1)
import Control.Plus (class Plus, empty)

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit, unit)

-- | The `MonadZero` type class has no members of its own; it just specifies
-- | that the type has both `Monad` and `Alternative` instances.
-- |
-- | Types which have `MonadZero` instances should also satisfy the following
-- | laws:
-- |
-- | - Annihilation: `empty >>= f = empty`
class (Monad m, Alternative m) <= MonadZero m

instance monadZeroArray :: MonadZero Array

-- | Fail using `Plus` if a condition does not hold, or
-- | succeed using `Monad` if it does.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Prelude
-- | import Control.Monad (bind)
-- | import Control.MonadZero (guard)
-- | import Data.Array ((..))
-- |
-- | factors :: Int -> Array Int
-- | factors n = do
-- |   a <- 1..n
-- |   b <- a..n
-- |   guard $ a * b == n
-- |   pure [a, b]
-- | ```
guard :: forall m. MonadZero m => Boolean -> m Unit
guard true = pure unit
guard false = empty

module Control.MonadZero
  ( class MonadZero
  , guard
  , module Control.Alt
  , module Control.Alternative
  , module Control.Applicative
  , module Control.Apply
  , module Control.Bind
  , module Control.Monad
  , module Control.Plus
  , module Data.Functor
  ) where

import Control.Alt (class Alt, alt, (<|>))
import Control.Alternative (class Alternative)
import Control.Applicative (class Applicative, pure, liftA1, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))
import Control.Monad (class Monad, ap, liftM1)
import Control.Plus (class Plus, empty)

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit, unit)

-- | The `MonadZero` type class has no members of its own; it just specifies
-- | that the type has both `Monad` and `Alternative` instances.
-- |
-- | Types which have `MonadZero` instances should also satisfy the following
-- | laws:
-- |
-- | - Annihilation: `empty >>= f = empty`
class (Monad m, Alternative m) <= MonadZero m

instance monadZeroArray :: MonadZero Array

-- | Fail using `Plus` if a condition does not hold, or
-- | succeed using `Monad` if it does.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array
-- |
-- | factors :: Number -> Array Number
-- | factors n = do
-- |   a <- 1 .. n
-- |   b <- 1 .. a
-- |   guard $ a * b == n
-- |   pure a
-- | ```
guard :: forall m. MonadZero m => Boolean -> m Unit
guard true = pure unit
guard false = empty


Add test for getUserData/setUserData methods

module Test.Handler (testSuite) where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Control.Monad.Trans
import Data.Array (head)
import Data.Default
import Data.Foreign.Class
import Data.Function
import Data.Maybe
import Node.Express.Types
import Node.Express.App hiding (apply)
import Node.Express.Handler
import Node.Express.Request
import Node.Express.Response
import Prelude hiding (id)
import Data.StrMap as StrMap
import Test.Mock
import Test.Unit
import Test.Unit.Assert
import Test.Unit.Console
import Unsafe.Coerce

foreign import cwdJson :: String
foreign import unsafeUpdateMapInPlace :: forall a e. StrMap.StrMap a -> String -> a -> Eff e Unit

testValue = "TestValue"
assertTestHeaderExists = assertTestHeader $ Just testValue
assertTestHeaderAbsent = assertTestHeader Nothing
assertTestHeaderWith = assertTestHeader <<< Just
sendTestRequest = sendRequest GET "http://example.com"

muteTest :: forall e. TestMockApp e
muteTest = lift $ assert "Muted" true

id :: forall a. a -> a
id a = a

testParams = do
    testExpress "getRouteParam" $ do
        setupMockApp $ use paramsHandler
        sendTestRequest withoutParams assertTestHeaderAbsent
        sendTestRequest withRouteParam assertTestHeaderExists
    testExpress "getBodyParam" $ do
        setupMockApp $ use paramsHandler
        sendTestRequest withoutParams assertTestHeaderAbsent
        sendTestRequest withBodyParam assertTestHeaderExists
    testExpress "getQueryParam" $ do
        setupMockApp $ use paramsHandler
        sendTestRequest withoutParams assertTestHeaderAbsent
        sendRequest GET urlWithQueryParam id assertTestHeaderExists
    testExpress "getQueryParams" $ do
        setupMockApp $ use paramsHandler
        sendTestRequest withoutParams assertTestHeaderAbsent
        sendRequest GET urlWithQueryParams id assertTestHeaderExists
  where
    testParam = "param"
    withoutParams  = id
    withRouteParam = setRouteParam testParam testValue
    withBodyParam  = setBodyParam  testParam testValue
    urlWithQueryParam = "http://example.com?" <> testParam <> "=" <> testValue
    urlWithQueryParams = urlWithQueryParam <> "&" <> testParam <> "=someOtherValue"
    paramsHandler  = do
        getRouteParam testParam >>= maybe (pure unit) setTestHeader
        getBodyParam  testParam >>= maybe (pure unit) setTestHeader
        getQueryParam testParam >>= maybe (pure unit) setTestHeader
        map head (getQueryParams testParam) >>= maybe (pure unit) setTestHeader

testHeaders = do
    testExpress "getRequestHeader" $ do
        let testHeaderName = "X-Test-Header"
            setupRequest = setRequestHeader testHeaderName testValue
        setupMockApp $ use $
            getRequestHeader testHeaderName >>= maybe (pure unit) setTestHeader
        sendTestRequest setupRequest assertTestHeaderExists

    testExpress "accepts" $ do
        let withAccepts = setRequestHeader "Accept"
        setupMockApp $ use $
            accepts "text/html" >>= maybe (pure unit) setTestHeader
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest (withAccepts "application/json") assertTestHeaderAbsent
        sendTestRequest (withAccepts "text/html") $ assertTestHeaderWith "text/html"
        sendTestRequest (withAccepts "text/xml, text/html") $ assertTestHeaderWith "text/html"

    testExpress "acceptsCharset" $ do
        let withAccepts = setRequestHeader "Accept-Charset"
        setupMockApp $ use $
            acceptsCharset "utf-8" >>= maybe (pure unit) setTestHeader
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest (withAccepts "cp-1251") assertTestHeaderAbsent
        sendTestRequest (withAccepts "utf-8") $ assertTestHeaderWith "utf-8"
        sendTestRequest (withAccepts "cp-1251, utf-8") $ assertTestHeaderWith "utf-8"

    testExpress "acceptsLanguage" $ do
        let withAccepts = setRequestHeader "Accept-Language"
        setupMockApp $ use $
            acceptsLanguage "en" >>= maybe (pure unit) setTestHeader
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest (withAccepts "ru") assertTestHeaderAbsent
        sendTestRequest (withAccepts "en") $ assertTestHeaderWith "en"
        sendTestRequest (withAccepts "ru, en, ch") $ assertTestHeaderWith "en"

    testExpress "hasType" $ do
        let contentType = "application/json"
            withContentType = setRequestHeader "Content-Type" contentType
        setupMockApp $ use $ do
            result <- hasType contentType
            if result then setTestHeader testValue else pure unit
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest withContentType assertTestHeaderExists

testCookies = do
    testExpress "getCookie" $ do
        setupMockApp $ use $
            getCookie testCookie >>= maybe (pure unit) setTestHeader
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest withTestCookie assertTestHeaderExists
        sendTestRequest withTestSignedCookie assertTestHeaderAbsent
    testExpress "getSignedCookie" $ do
        setupMockApp $ use $
            getSignedCookie testCookie >>= maybe (pure unit) setTestHeader
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest withTestCookie assertTestHeaderAbsent
        sendTestRequest withTestSignedCookie assertTestHeaderExists
  where
    testCookie = "cookie"
    withTestCookie = setRequestCookie testCookie testValue
    withTestSignedCookie = setRequestSignedCookie testCookie testValue

testMisc = do
    testExpress "getRoute" $ do
        let route = "/some/(.+)/path"
        setupMockApp $ get route $ getRoute >>= setTestHeader
        sendRequest GET "http://example.com/" id assertTestHeaderAbsent
        sendRequest GET "http://example.com/some/possible/path" id $ assertTestHeaderWith route
        sendRequest GET "http://example.com/some/another/path" id $ assertTestHeaderWith route
        sendRequest GET "http://example.com/some/path" id assertTestHeaderAbsent

    testExpress "getRemoteIp" $ do
        setupMockApp $ use $ getRemoteIp >>= setTestHeader
        sendTestRequest id $ assertTestHeaderWith "0.0.0.0"

    testExpress "getRemoteIps" $ do
        let ips = ["0.0.0.0", "0.0.0.1", "0.0.0.2"]
        setupMockApp $ use $ getRemoteIps >>= (show >>> setTestHeader)
        sendTestRequest id $ assertTestHeaderWith (show ips)

    testExpress "getPath" $ do
        setupMockApp $ use $ getPath >>= setTestHeader
        sendRequest GET "http://example.com/" id $ assertTestHeaderWith "/"
        sendRequest GET "http://example.com/some/path" id $ assertTestHeaderWith "/some/path"

    testExpress "getHostname" $ do
        setupMockApp $ use $ getHostname >>= setTestHeader
        sendTestRequest id $ assertTestHeaderWith "example.com"

    testExpress "getSubdomains" $ do
        setupMockApp $ use $ getSubdomains >>= (show >>> setTestHeader)
        sendTestRequest id $ assertTestHeaderWith "[]"
        sendRequest GET "http://foo.bar.baz.com" id $ assertTestHeaderWith $ show ["foo", "bar"]

    testExpress "isFresh" $ do
        setupMockApp $ use $ do
            result <- (\f s -> f && not s) <$> isFresh <*> isStale
            if result then setTestHeader testValue else pure unit
        sendTestRequest id assertTestHeaderExists

    testExpress "isXhr" $ do
        setupMockApp $ use $ do
            result <- isXhr
            if not result then setTestHeader testValue else pure unit
        sendTestRequest id assertTestHeaderExists

    testExpress "getProtocol" $ do
        setupMockApp $ use $ getProtocol >>= maybe (pure unit) (show >>> setTestHeader)
        sendTestRequest id $ assertTestHeaderWith (show Http)

    testExpress "getMethod" $ do
        setupMockApp $ use $ getMethod >>= maybe (pure unit) (show >>> setTestHeader)
        sendTestRequest id $ assertTestHeaderWith (show GET)

    testExpress "getUrl" $ do
        setupMockApp $ use $ getUrl >>= setTestHeader
        sendTestRequest id $ assertTestHeaderWith "http://example.com"

    testExpress "getOriginalUrl" $ do
        setupMockApp $ use $ getOriginalUrl >>= setTestHeader
        sendTestRequest id $ assertTestHeaderWith "http://example.com"

    testExpress "getUserData + setUserData" $ do
        setupMockApp $ do
            use $ setUserData "key" "TEST-DATA"
            get "/" $ getUserData "key" >>= maybe (pure unit) setTestHeader
        sendTestRequest id $ assertTestHeaderWith "TEST-DATA"

testResponse = do
    testExpress "setStatus" $ do
        sendTestRequest id $ assertStatusCode 0
        setupMockApp $ use $ setStatus 200
        sendTestRequest id $ assertStatusCode 200

    testExpress "(get)setResponseHeader" $ do
        setupMockApp $ use $ do
            setResponseHeader "X-Foo-Bar" "foo"
            maybeFoo <- getResponseHeader "X-Foo-Bar"
            if maybeFoo == Just "foo"
                then setTestHeader testValue
                else pure unit
        sendTestRequest id assertTestHeaderExists

    testExpress "headersSent" $ do
        setupMockApp $ use $ do
            headersAreNotSentBeforeSend <- map not headersSent
            send "Something"
            headersAreSentAfterSend <- headersSent
            if (headersAreNotSentBeforeSend && headersAreSentAfterSend)
                then setTestHeader testValue
                else pure unit
        sendTestRequest id assertTestHeaderExists

    testExpress "setCookie" $ do
        setupMockApp $ use $ setCookie testCookie testValue def
        sendTestRequest id (assertCookieValue testCookie $ Just testValue)

    testExpress "clearCookie" $ do
        let withTestCookie = setRequestCookie testCookie testValue
            assertTestCookieAbsent = assertCookieValue testCookie Nothing
        setupMockApp $ use $ clearCookie testCookie "/"
        sendTestRequest id assertTestCookieAbsent
        sendTestRequest withTestCookie assertTestCookieAbsent

    testExpress "send" $ do
        setupMockApp $ use $ send testValue
        sendTestRequest id $ assertData testValue

    testExpress "sendJson" $ do
        setupMockApp $ use $ sendJson testData
        sendTestRequest id $ assertData testDataStr

    testExpress "sendJsonp" $ do
        setupMockApp $ use $ sendJsonp testData
        sendTestRequest id $ assertData testDataStr

    testExpress "render" $ do
        setupMockApp $ use $ render "test-view" testData
        sendTestRequest id $ assertData testDataRendered

    testExpress "redirect" $ do
        setupMockApp $ use $ redirect exampleCom
        sendTestRequest id $ \response -> do
            assertStatusCode 302 response
            assertHeader "Location" (Just exampleCom) response

    testExpress "redirectWithStatus" $ do
        setupMockApp $ use $ redirectWithStatus 301 exampleCom
        sendTestRequest id $ \response -> do
            assertStatusCode 301 response
            assertHeader "Location" (Just exampleCom) response

    testExpress "setLocation" $ do
        setupMockApp $ use $ setLocation exampleCom
        sendTestRequest id $ assertHeader "Location" (Just exampleCom)

    testExpress "setContentType" $ do
        setupMockApp $ use $ setContentType "text/html"
        sendTestRequest id $ assertHeader "Content-Type" (Just "text/html")

    testExpress "sendFile" $ do
        setupMockApp $ use $ sendFile testFile
        sendTestRequest id $ \response -> do
            assertHeader filepathHeader (Just testFile) response
            assertData ("{\"root\":" <> cwdJson <> "}") response

    testExpress "sendFileExt" $ do
        setupMockApp $ use $ sendFileExt testFile testData (\_ -> pure unit)
        sendTestRequest id $ \response -> do
            assertHeader filepathHeader (Just testFile) response
            assertData testDataStr response

    testExpress "sendFileExt (with error)" $ do
        setupMockApp $ use $ sendFileExt testFile {triggerError: true} testErrorHandler
        sendTestRequest id $ assertHeader testErrorHeader (Just testValue)

    testExpress "download" $ do
        setupMockApp $ use $ download testFile
        sendTestRequest id $ \response -> do
            assertHeader filepathHeader (Just testFile) response
            assertHeader realFilepathHeader (Just testFile) response

    testExpress "downloadExt" $ do
        setupMockApp $ use $ downloadExt testFile "renamed.txt" (\_ -> pure unit)
        sendTestRequest id $ \response -> do
            assertHeader filepathHeader (Just "renamed.txt") response
            assertHeader realFilepathHeader (Just testFile) response

    testExpress "downloadExt (with error)" $ do
        setupMockApp $ use $ downloadExt testFile "triggerError" testErrorHandler
        sendTestRequest id $ assertHeader testErrorHeader (Just testValue)
  where
    exampleCom = "http://example.com"
    testCookie = "testCookie"
    testData = {foo: "bar"}
    testDataStr = "{\"foo\":\"bar\"}"
    testDataRendered = "Rendered test-view with data: {\"foo\":\"bar\"}"
    testFile = "test.txt"
    filepathHeader = "X-Filepath"
    realFilepathHeader = "X-Real-Filepath"
    testErrorHeader = "X-Test-Error"
    testErrorHandler :: forall e. Error -> Eff e Unit
    testErrorHandler = \respAsError ->
        let response = unsafeCoerce respAsError in
        unsafeUpdateMapInPlace (response.headers) testErrorHeader testValue

testSuite = suite "Handler" do
    testParams
    testHeaders
    testCookies
    testMisc
    testResponse

module Test.Handler (testSuite) where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Control.Monad.Trans
import Data.Array (head)
import Data.Default
import Data.Foreign.Class
import Data.Function
import Data.Maybe
import Node.Express.Types
import Node.Express.App hiding (apply)
import Node.Express.Handler
import Node.Express.Request
import Node.Express.Response
import Prelude hiding (id)
import Data.StrMap as StrMap
import Test.Mock
import Test.Unit
import Test.Unit.Assert
import Test.Unit.Console
import Unsafe.Coerce

foreign import cwdJson :: String
foreign import unsafeUpdateMapInPlace :: forall a e. StrMap.StrMap a -> String -> a -> Eff e Unit

testValue = "TestValue"
assertTestHeaderExists = assertTestHeader $ Just testValue
assertTestHeaderAbsent = assertTestHeader Nothing
assertTestHeaderWith = assertTestHeader <<< Just
sendTestRequest = sendRequest GET "http://example.com"

muteTest :: forall e. TestMockApp e
muteTest = lift $ assert "Muted" true

id :: forall a. a -> a
id a = a

testParams = do
    testExpress "getRouteParam" $ do
        setupMockApp $ use paramsHandler
        sendTestRequest withoutParams assertTestHeaderAbsent
        sendTestRequest withRouteParam assertTestHeaderExists
    testExpress "getBodyParam" $ do
        setupMockApp $ use paramsHandler
        sendTestRequest withoutParams assertTestHeaderAbsent
        sendTestRequest withBodyParam assertTestHeaderExists
    testExpress "getQueryParam" $ do
        setupMockApp $ use paramsHandler
        sendTestRequest withoutParams assertTestHeaderAbsent
        sendRequest GET urlWithQueryParam id assertTestHeaderExists
    testExpress "getQueryParams" $ do
        setupMockApp $ use paramsHandler
        sendTestRequest withoutParams assertTestHeaderAbsent
        sendRequest GET urlWithQueryParams id assertTestHeaderExists
  where
    testParam = "param"
    withoutParams  = id
    withRouteParam = setRouteParam testParam testValue
    withBodyParam  = setBodyParam  testParam testValue
    urlWithQueryParam = "http://example.com?" <> testParam <> "=" <> testValue
    urlWithQueryParams = urlWithQueryParam <> "&" <> testParam <> "=someOtherValue"
    paramsHandler  = do
        getRouteParam testParam >>= maybe (pure unit) setTestHeader
        getBodyParam  testParam >>= maybe (pure unit) setTestHeader
        getQueryParam testParam >>= maybe (pure unit) setTestHeader
        map head (getQueryParams testParam) >>= maybe (pure unit) setTestHeader

testHeaders = do
    testExpress "getRequestHeader" $ do
        let testHeaderName = "X-Test-Header"
            setupRequest = setRequestHeader testHeaderName testValue
        setupMockApp $ use $
            getRequestHeader testHeaderName >>= maybe (pure unit) setTestHeader
        sendTestRequest setupRequest assertTestHeaderExists

    testExpress "accepts" $ do
        let withAccepts = setRequestHeader "Accept"
        setupMockApp $ use $
            accepts "text/html" >>= maybe (pure unit) setTestHeader
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest (withAccepts "application/json") assertTestHeaderAbsent
        sendTestRequest (withAccepts "text/html") $ assertTestHeaderWith "text/html"
        sendTestRequest (withAccepts "text/xml, text/html") $ assertTestHeaderWith "text/html"

    testExpress "acceptsCharset" $ do
        let withAccepts = setRequestHeader "Accept-Charset"
        setupMockApp $ use $
            acceptsCharset "utf-8" >>= maybe (pure unit) setTestHeader
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest (withAccepts "cp-1251") assertTestHeaderAbsent
        sendTestRequest (withAccepts "utf-8") $ assertTestHeaderWith "utf-8"
        sendTestRequest (withAccepts "cp-1251, utf-8") $ assertTestHeaderWith "utf-8"

    testExpress "acceptsLanguage" $ do
        let withAccepts = setRequestHeader "Accept-Language"
        setupMockApp $ use $
            acceptsLanguage "en" >>= maybe (pure unit) setTestHeader
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest (withAccepts "ru") assertTestHeaderAbsent
        sendTestRequest (withAccepts "en") $ assertTestHeaderWith "en"
        sendTestRequest (withAccepts "ru, en, ch") $ assertTestHeaderWith "en"

    testExpress "hasType" $ do
        let contentType = "application/json"
            withContentType = setRequestHeader "Content-Type" contentType
        setupMockApp $ use $ do
            result <- hasType contentType
            if result then setTestHeader testValue else pure unit
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest withContentType assertTestHeaderExists

testCookies = do
    testExpress "getCookie" $ do
        setupMockApp $ use $
            getCookie testCookie >>= maybe (pure unit) setTestHeader
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest withTestCookie assertTestHeaderExists
        sendTestRequest withTestSignedCookie assertTestHeaderAbsent
    testExpress "getSignedCookie" $ do
        setupMockApp $ use $
            getSignedCookie testCookie >>= maybe (pure unit) setTestHeader
        sendTestRequest id assertTestHeaderAbsent
        sendTestRequest withTestCookie assertTestHeaderAbsent
        sendTestRequest withTestSignedCookie assertTestHeaderExists
  where
    testCookie = "cookie"
    withTestCookie = setRequestCookie testCookie testValue
    withTestSignedCookie = setRequestSignedCookie testCookie testValue

testMisc = do
    testExpress "getRoute" $ do
        let route = "/some/(.+)/path"
        setupMockApp $ get route $ getRoute >>= setTestHeader
        sendRequest GET "http://example.com/" id assertTestHeaderAbsent
        sendRequest GET "http://example.com/some/possible/path" id $ assertTestHeaderWith route
        sendRequest GET "http://example.com/some/another/path" id $ assertTestHeaderWith route
        sendRequest GET "http://example.com/some/path" id assertTestHeaderAbsent

    testExpress "getRemoteIp" $ do
        setupMockApp $ use $ getRemoteIp >>= setTestHeader
        sendTestRequest id $ assertTestHeaderWith "0.0.0.0"

    testExpress "getRemoteIps" $ do
        let ips = ["0.0.0.0", "0.0.0.1", "0.0.0.2"]
        setupMockApp $ use $ getRemoteIps >>= (show >>> setTestHeader)
        sendTestRequest id $ assertTestHeaderWith (show ips)

    testExpress "getPath" $ do
        setupMockApp $ use $ getPath >>= setTestHeader
        sendRequest GET "http://example.com/" id $ assertTestHeaderWith "/"
        sendRequest GET "http://example.com/some/path" id $ assertTestHeaderWith "/some/path"

    testExpress "getHostname" $ do
        setupMockApp $ use $ getHostname >>= setTestHeader
        sendTestRequest id $ assertTestHeaderWith "example.com"

    testExpress "getSubdomains" $ do
        setupMockApp $ use $ getSubdomains >>= (show >>> setTestHeader)
        sendTestRequest id $ assertTestHeaderWith "[]"
        sendRequest GET "http://foo.bar.baz.com" id $ assertTestHeaderWith $ show ["foo", "bar"]

    testExpress "isFresh" $ do
        setupMockApp $ use $ do
            result <- (\f s -> f && not s) <$> isFresh <*> isStale
            if result then setTestHeader testValue else pure unit
        sendTestRequest id assertTestHeaderExists

    testExpress "isXhr" $ do
        setupMockApp $ use $ do
            result <- isXhr
            if not result then setTestHeader testValue else pure unit
        sendTestRequest id assertTestHeaderExists

    testExpress "getProtocol" $ do
        setupMockApp $ use $ getProtocol >>= maybe (pure unit) (show >>> setTestHeader)
        sendTestRequest id $ assertTestHeaderWith (show Http)

    testExpress "getMethod" $ do
        setupMockApp $ use $ getMethod >>= maybe (pure unit) (show >>> setTestHeader)
        sendTestRequest id $ assertTestHeaderWith (show GET)

    testExpress "getUrl" $ do
        setupMockApp $ use $ getUrl >>= setTestHeader
        sendTestRequest id $ assertTestHeaderWith "http://example.com"

    testExpress "getOriginalUrl" $ do
        setupMockApp $ use $ getOriginalUrl >>= setTestHeader
        sendTestRequest id $ assertTestHeaderWith "http://example.com"

testResponse = do
    testExpress "setStatus" $ do
        sendTestRequest id $ assertStatusCode 0
        setupMockApp $ use $ setStatus 200
        sendTestRequest id $ assertStatusCode 200

    testExpress "(get)setResponseHeader" $ do
        setupMockApp $ use $ do
            setResponseHeader "X-Foo-Bar" "foo"
            maybeFoo <- getResponseHeader "X-Foo-Bar"
            if maybeFoo == Just "foo"
                then setTestHeader testValue
                else pure unit
        sendTestRequest id assertTestHeaderExists

    testExpress "headersSent" $ do
        setupMockApp $ use $ do
            headersAreNotSentBeforeSend <- map not headersSent
            send "Something"
            headersAreSentAfterSend <- headersSent
            if (headersAreNotSentBeforeSend && headersAreSentAfterSend)
                then setTestHeader testValue
                else pure unit
        sendTestRequest id assertTestHeaderExists

    testExpress "setCookie" $ do
        setupMockApp $ use $ setCookie testCookie testValue def
        sendTestRequest id (assertCookieValue testCookie $ Just testValue)

    testExpress "clearCookie" $ do
        let withTestCookie = setRequestCookie testCookie testValue
            assertTestCookieAbsent = assertCookieValue testCookie Nothing
        setupMockApp $ use $ clearCookie testCookie "/"
        sendTestRequest id assertTestCookieAbsent
        sendTestRequest withTestCookie assertTestCookieAbsent

    testExpress "send" $ do
        setupMockApp $ use $ send testValue
        sendTestRequest id $ assertData testValue

    testExpress "sendJson" $ do
        setupMockApp $ use $ sendJson testData
        sendTestRequest id $ assertData testDataStr

    testExpress "sendJsonp" $ do
        setupMockApp $ use $ sendJsonp testData
        sendTestRequest id $ assertData testDataStr

    testExpress "render" $ do
        setupMockApp $ use $ render "test-view" testData
        sendTestRequest id $ assertData testDataRendered

    testExpress "redirect" $ do
        setupMockApp $ use $ redirect exampleCom
        sendTestRequest id $ \response -> do
            assertStatusCode 302 response
            assertHeader "Location" (Just exampleCom) response

    testExpress "redirectWithStatus" $ do
        setupMockApp $ use $ redirectWithStatus 301 exampleCom
        sendTestRequest id $ \response -> do
            assertStatusCode 301 response
            assertHeader "Location" (Just exampleCom) response

    testExpress "setLocation" $ do
        setupMockApp $ use $ setLocation exampleCom
        sendTestRequest id $ assertHeader "Location" (Just exampleCom)

    testExpress "setContentType" $ do
        setupMockApp $ use $ setContentType "text/html"
        sendTestRequest id $ assertHeader "Content-Type" (Just "text/html")

    testExpress "sendFile" $ do
        setupMockApp $ use $ sendFile testFile
        sendTestRequest id $ \response -> do
            assertHeader filepathHeader (Just testFile) response
            assertData ("{\"root\":" <> cwdJson <> "}") response

    testExpress "sendFileExt" $ do
        setupMockApp $ use $ sendFileExt testFile testData (\_ -> pure unit)
        sendTestRequest id $ \response -> do
            assertHeader filepathHeader (Just testFile) response
            assertData testDataStr response

    testExpress "sendFileExt (with error)" $ do
        setupMockApp $ use $ sendFileExt testFile {triggerError: true} testErrorHandler
        sendTestRequest id $ assertHeader testErrorHeader (Just testValue)

    testExpress "download" $ do
        setupMockApp $ use $ download testFile
        sendTestRequest id $ \response -> do
            assertHeader filepathHeader (Just testFile) response
            assertHeader realFilepathHeader (Just testFile) response

    testExpress "downloadExt" $ do
        setupMockApp $ use $ downloadExt testFile "renamed.txt" (\_ -> pure unit)
        sendTestRequest id $ \response -> do
            assertHeader filepathHeader (Just "renamed.txt") response
            assertHeader realFilepathHeader (Just testFile) response

    testExpress "downloadExt (with error)" $ do
        setupMockApp $ use $ downloadExt testFile "triggerError" testErrorHandler
        sendTestRequest id $ assertHeader testErrorHeader (Just testValue)
  where
    exampleCom = "http://example.com"
    testCookie = "testCookie"
    testData = {foo: "bar"}
    testDataStr = "{\"foo\":\"bar\"}"
    testDataRendered = "Rendered test-view with data: {\"foo\":\"bar\"}"
    testFile = "test.txt"
    filepathHeader = "X-Filepath"
    realFilepathHeader = "X-Real-Filepath"
    testErrorHeader = "X-Test-Error"
    testErrorHandler :: forall e. Error -> Eff e Unit
    testErrorHandler = \respAsError ->
        let response = unsafeCoerce respAsError in
        unsafeUpdateMapInPlace (response.headers) testErrorHeader testValue

testSuite = suite "Handler" do
    testParams
    testHeaders
    testCookies
    testMisc
    testResponse


Improve Arb instance

Improve Arb instance

module Main where

import Data.Maybe
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck
import Test.QuickCheck.Functions
import Test.QuickCheck.Classes

type Ty = Maybe Number

main = do

  let ty = Just 0

  trace "test equality"
  check1 $ \n -> Just n == Just n
  assert $ Nothing == Nothing :: Ty

  trace "test inequality"
  check1 $ \n -> Just n  /= Nothing
  check1 $ \n -> Nothing /= Just n
  check1 $ \n -> Just n  /= Just (n + 1)

  trace "test order"
  check2 $ \x y -> compare (Just x) (Just y) == compare x y
  check1 $ \x -> compare Nothing (Just x) == LT
  check1 $ \x -> compare (Just x) Nothing == GT
  check1 $ \x -> compare Nothing (Nothing :: Ty) == EQ

  trace "maybe should transform a value wrapped in a Just"
  check1 $ \n -> maybe 0 negate (Just n) == -n

  trace "maybe should return the default value when applied to Nothing"
  check1 $ \n -> maybe n id Nothing == n

  trace "isJust should return the appropriate value"
  assert $ isJust (Just {}) == true
  assert $ isJust Nothing == false

  trace "isNothing should return the appropriate value"
  assert $ isNothing Nothing == true
  assert $ isNothing (Just {}) == false

  trace "test functor laws"
  checkFunctor ty

  trace "test applicative laws"
  checkApplicative ty ty ty

  trace "test monad laws"
  checkMonad ty

assert :: Boolean -> QC
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC
check1 = quickCheck

check2 :: (Number -> Number -> Boolean) -> QC
check2 = quickCheck

instance arbAToMaybeB :: (Arb (a -> b)) => Arb (a -> Maybe b) where
  arb = do
    f <- arb
    jn <- arb
    return $ \x -> if jn then Just (f x) else Nothing

instance showAToMaybeB :: (Arb (a -> b)) => Show (a -> Maybe b) where
  show _ = "<a -> Maybe b>"

module Main where

import Data.Maybe
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck
import Test.QuickCheck.Functions
import Test.QuickCheck.Classes

type Ty = Maybe Number

main = do

  let ty = Just 0

  trace "test equality"
  check1 $ \n -> Just n == Just n
  assert $ Nothing == Nothing :: Ty

  trace "test inequality"
  check1 $ \n -> Just n  /= Nothing
  check1 $ \n -> Nothing /= Just n
  check1 $ \n -> Just n  /= Just (n + 1)

  trace "test order"
  check2 $ \x y -> compare (Just x) (Just y) == compare x y
  check1 $ \x -> compare Nothing (Just x) == LT
  check1 $ \x -> compare (Just x) Nothing == GT
  check1 $ \x -> compare Nothing (Nothing :: Ty) == EQ

  trace "maybe should transform a value wrapped in a Just"
  check1 $ \n -> maybe 0 negate (Just n) == -n

  trace "maybe should return the default value when applied to Nothing"
  check1 $ \n -> maybe n id Nothing == n

  trace "isJust should return the appropriate value"
  assert $ isJust (Just {}) == true
  assert $ isJust Nothing == false

  trace "isNothing should return the appropriate value"
  assert $ isNothing Nothing == true
  assert $ isNothing (Just {}) == false

  trace "test functor laws"
  checkFunctor ty

  trace "test applicative laws"
  checkApplicative ty ty ty

  trace "test monad laws"
  checkMonad ty

assert :: Boolean -> QC
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC
check1 = quickCheck

check2 :: (Number -> Number -> Boolean) -> QC
check2 = quickCheck

instance arbAToMaybeB :: (Arb (a -> b)) => Arb (a -> Maybe b) where
  arb = do
    f <- arb
    return $ \x -> Just (f x)

instance showAToMaybeB :: (Arb (a -> b)) => Show (a -> Maybe b) where
  show _ = "<a -> Maybe b>"


Proper equality

Proper equality

Original commit dbb81a5ab70c6d94a0e65351dc6b1e8657508485

module IR where

import Prelude
import Data.List (List())
import Data.Set (Set)

type IRProperty = { name :: String, typ :: IRType }
type IRClassData = { name :: String, properties :: Set IRProperty }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Set IRType)

-- TODO finish later! Just a little equality will go a long way for now
instance eqIRType :: Eq IRType where
    eq IRNothing IRNothing = true
    eq IRNull IRNull = true
    eq IRInteger IRInteger = true
    eq IRDouble IRDouble = true
    eq IRBool IRBool = true
    eq IRString IRString = true
    eq (IRArray a) (IRArray b) = a == b
    eq (IRClass a) (IRClass b) = a == b
    eq (IRUnion a) (IRUnion b) = a == b
    eq _ _ = false

module IR where

import Prelude
import Data.List (List())
import Data.Set (Set)

type IRProperty = { name :: String, typ :: IRType }
type IRClassData = { name :: String, properties :: Set IRProperty }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Set IRType)

-- TODO finish later! Just a little equality will go a long way for now
instance eqIRType :: Eq IRType where
    eq IRString IRString = true
    eq IRDouble IRDouble = true
    eq _ _ = false


[CSM-151] Remove constraint that base58 paper vend redeem code should be 44 chars long

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPassPhrase, mkCPostVendWalletRedeem, emptyCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7, mkEffFn5, EffFn5)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)

updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale

getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
send = mkEffFn3 \addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)

sendExtended :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String String (Promise Json)
sendExtended = mkEffFn6 \addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least len words
isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len

newWallet :: forall eff . EffFn4 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String
  (Promise Json)
newWallet = mkEffFn4 \wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet $ mkCPassPhrase "") $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWallet = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
nextUpdate = fromAff $ map encodeJson B.nextUpdate

applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
applyUpdate = fromAff B.applyUpdate

systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
systemVersion = fromAff $ map encodeJson B.systemVersion

redeemADA :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
redeemADA = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemADA <<< mkCWalletRedeem seed

postVendRedeemADA :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
postVendRedeemADA = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.postVendRedeemADA <<< mkCPostVendWalletRedeem seed mnemonic

reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total

importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey

syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
syncProgress = fromAff $ map encodeJson B.syncProgress

testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedeemCode :: String -> Boolean
isValidRedeemCode code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid postvend code is base58 encoded 32byte data
isValidPostVendRedeemCode :: String -> Boolean
isValidPostVendRedeemCode code = maybe false (const true) $ B58.decode code

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPassPhrase, mkCPostVendWalletRedeem, emptyCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7, mkEffFn5, EffFn5)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)

updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale

getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
send = mkEffFn3 \addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)

sendExtended :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String String (Promise Json)
sendExtended = mkEffFn6 \addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least len words
isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len

newWallet :: forall eff . EffFn4 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String
  (Promise Json)
newWallet = mkEffFn4 \wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet $ mkCPassPhrase "") $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWallet = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
nextUpdate = fromAff $ map encodeJson B.nextUpdate

applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
applyUpdate = fromAff B.applyUpdate

systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
systemVersion = fromAff $ map encodeJson B.systemVersion

redeemADA :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
redeemADA = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemADA <<< mkCWalletRedeem seed

postVendRedeemADA :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
postVendRedeemADA = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.postVendRedeemADA <<< mkCPostVendWalletRedeem seed mnemonic

reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total

importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey

syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
syncProgress = fromAff $ map encodeJson B.syncProgress

testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedeemCode :: String -> Boolean
isValidRedeemCode code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid postvend code is base58 encoded 32byte data
isValidPostVendRedeemCode :: String -> Boolean
isValidPostVendRedeemCode code = maybe false (const $ 44 == length code) $ B58.decode code


withFileDetails

withFileDetails

module App.View where

import Text.Smolder.HTML hiding (address)

import App.Routing (Location(..))
import App.State (Event(..), State, signerLens)
import App.State.Contracts as Contracts
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Locations as Locations
import App.State.Signers as Signers
import Data.Array (fromFoldable)
import Data.Either (Either(..))
import Data.Lens ((^.))
import Data.Map (toUnfoldable, values)
import Data.Maybe (Maybe(..), fromJust, isJust, maybe)
import Data.String (drop, length, take, toLower)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.Eth.Contracts (class EthContract, getAddress)
import Lib.Eth.Web3 (TxHash(..), TxStatus(..))
import Lib.SignHash.Proofs.Display (SignerDisplayStatus(..), signerDisplayStatus)
import Lib.SignHash.Proofs.Methods (ProofMethod(..), canonicalName)
import Lib.SignHash.Proofs.Types (ProofState(..), ProofVerification(..))
import Lib.SignHash.Proofs.Values as ProofValues
import Lib.SignHash.Types (Address(..), HashSigner(..))
import Partial.Unsafe (unsafePartial)
import Prelude (discard, show, ($), (-), (<<<), (<>))
import Pux.DOM.Events (DOMEvent, onChange, onClick, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, src, type')
import Text.Smolder.HTML.Attributes as A
import Text.Smolder.Markup (Attribute, EventHandlers, attribute, text, (!), (#!))

foreign import images ::
  { logo :: String
  , ethIcon :: String }

dataQA :: String -> Attribute
dataQA = attribute "data-qa"

view :: State -> HTML Event
view state =
  do
    div ! className "Content" $ do
      div ! className "Header" $ do
        img ! src images.logo
        span ! className "title" $ text "SignHash"

      nav ! className "Navbar" $ do
        ul do
          li $ a ! A.href "#" #! onClick (navigate Sign) $ text "Sign"
          li $ a ! A.href "#" #! onClick (navigate Verify) $ text "Verify"

      viewContent state

      hr
      div ! className "Contracts-info" $ do
        viewContracts state.contracts
      clear

viewContent :: State -> HTML Event
viewContent state@{ location: Verify } = do
  withFileDetails state.file $ \file -> do
    viewFileSigners state file
viewContent state@{ location: Sign } = do
  withFileDetails state.file $ \file -> do
    sectionHeader "Your account"
    guardAccountUnlocked state.myAccount $ viewSigningDetails state file

withFileDetails ::
  Maybe Files.State
  -> (Files.State -> HTML Event)
  -> HTML Event
withFileDetails file viewDetails = do
  viewFileInput (isJust file)
  case file of
    Nothing -> empty
    Just file -> do
      viewFile file
      viewDetails file

viewFileSigners :: State -> Files.State -> HTML Event
viewFileSigners state file = do
  div $ signerStatus file.signer
  where
    signerStatus = case _ of
      Nothing -> sectionHeader "Loading signer..."
      Just (NoSigner) -> sectionHeader "No signers"
      Just (HashSigner address) -> do
        sectionHeader "Signers"
        case state ^. signerLens address of
          Nothing -> div do
            text loading
            hr
          Just value -> div do
            child (Signer address) viewSigner $ value

viewSigningDetails :: State -> Files.State -> Address -> HTML Event
viewSigningDetails state file address = do
  div ! dataQA "my-id" $ do
    let myDetails = expectResult $ state ^. signerLens address
    child (Signer address) viewSigner myDetails
    case file.result of
      Nothing -> empty
      Just fileDetails ->
        case state.signingTx of
          Nothing ->
            a
              ! A.href "#"
              ! dataQA "sign"
              #! onClickAction (SignFile fileDetails.hash)
              $ text "Sign it"
          Just (Left err) ->
            text $ "Error while issuing transaction"
          Just (Right hash) -> do
            text $ "Issued tx "
            let txStatus = Contracts.viewTxResult hash state.contracts
            txLink hash txStatus

viewContracts :: Contracts.State -> HTML Event
viewContracts Contracts.Loading =
  text $ "Loading contract..."
viewContracts (Contracts.Loaded state) = do
  contractLink "SignHash" state.signHash
  br
  contractLink "SignProof" state.signProof
  where
    contractLink :: forall c. EthContract c => String -> c -> HTML Event
    contractLink name contract = do
      span $ text $ name <> ": "
      (addressLink $ getAddress contract)
        ! dataQA ((toLower name) <> "-address")

viewContracts (Contracts.Error err) = do
  div
    ! A.title err
    $ text "Error while loading contract"

viewFileInput :: Boolean -> HTML Event
viewFileInput small =
  div do
    label
      ! for "file-upload"
      ! className ("File-upload" <> if small then " small" else "")
      #! onDrop handleNewFiles
      #! onDragOver ignoreEvent
      $ do
        renderIcon "fa-file-o"
        text "Upload file"
        if small then empty else
          div ! className "hint"
          $ text "Click or drag and drop on the page"
    input
      ! id "file-upload"
      ! type' "file"
      #! onChange handleNewFiles
  where
    handleNewFiles ev =
      preventingDefault (FileInput $ FileInputs.newFilesEvent ev) ev

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } = do
  div ! className "Files Section" $ do
    div ! className "row" $ do
      renderRow "Filename" $ text $ meta.name
      renderRow "SHA256" $ maybe (text loading) renderHash result
      renderRow "Size" $ renderSize meta.size

  where
    renderRow label value =
      div ! className "columns attribute four" $ do
        span ! className "header" $ text (label <> ":")
        span ! className "value" $ value

    renderSigner (HashSigner address) = show address
    renderSigner NoSigner = "Not signed"

    renderHash { hash } =
      let visibleOffset = 6
      in a
         ! dataQA "checksum"
         ! A.title hash
         ! A.href "#"
         $ text $ take visibleOffset hash
           <> "..."
           <> drop (length hash - visibleOffset) hash

    renderSize size = text $ show meta.size <> " B"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs, blockie } = do
  div ! className "Signer" $ do
    div ! className "header" $ do
      span ! className "status" $ do
        viewSignerStatus
    viewProofs address proofArray
    clear
  where
    proofStates = fromFoldable $ values proofs

    proofArray :: Array (Tuple ProofMethod ProofState)
    proofArray = toUnfoldable proofs

    viewSignerStatus =
      case signerDisplayStatus proofStates of
        SignerLoading -> renderIcon "fa-circle-o-notch loading"
        SignerVerified -> renderBlockie blockie
        SignerVerificationFailed -> renderIcon "fa-exclamation-circle failed"
        SignerNetworkError -> renderIcon "fa-question-circle-o network-error"

viewProofs ::
  Address
  -> Array (Tuple ProofMethod ProofState)
  -> HTML Signers.Event
viewProofs address proofs =
  div ! className "proofs" $ do
    renderEthProof
    for_ proofs renderProof
  where
    renderProof (Tuple method state) = do
      case state of
        Finished result -> renderFinishedProof method result
        NetworkError -> renderNetworkError method
        Pending -> empty

    renderFinishedProof method Unavailable = empty
    renderFinishedProof method (Unverified error) =
      div
        ! className ("proof " <> "failed")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          span ! dataQA "error" ! A.title (show error)
            $ text $ show method <> " verification failed"

    renderFinishedProof method (Verified proofValue) =
      div
        ! className ("proof " <> "verified")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          a ! A.href (methodHref method proof) ! A.target "_blank" $ text proof
      where
        proof = ProofValues.extract proofValue

    renderNetworkError method =
      div ! className ("proof" <> "network-error") $ do
        methodIcon method
        text $ "Network error while fetching proof"

    renderEthProof =
      div ! className "proof" $ do
        renderEthIcon
        (addressLink address) ! dataQA "proof-details-eth"

    methodIcon GitHub = renderIcon "fa-github"
    methodIcon HTTP = renderIcon "fa-world"

    methodHref GitHub username =
      "https://github.com/" <> username
    methodHref HTTP domain =
      "http://" <> domain

guardAccountUnlocked ::
  Contracts.ETHAccountState Address -> (Address -> HTML Event) -> HTML Event
guardAccountUnlocked state view = do
  case state of
    Contracts.Unavailable -> h4 $ text $ "Please install MetaMask extension"
    Contracts.Locked -> h4 $ text $ "Please unlock MetaMask"
    Contracts.Available address -> view address

sectionHeader :: forall a. String -> HTML a
sectionHeader msg =
  h4 ! className "Section-header" $ text msg

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa fa-lg " <> name) $ text ""

renderEthIcon :: forall a. Html a
renderEthIcon =
  img
  ! className "Icon"
  ! src images.ethIcon

renderBlockie :: forall a. String -> HTML a
renderBlockie blockieSrc =
  img ! className "blockie" ! src blockieSrc

loading :: String
loading = "Loading..."

empty :: forall a. HTML a
empty = text ""

clear :: forall a. HTML a
clear = div ! className "Clear" $ empty

addressLink :: forall a. Address -> HTML a
addressLink address = do
  a
  ! A.href (addressURL address)
  ! className "AddressURL"
  ! A.target "_blank"
  $ text $ show address

txLink :: forall a. TxHash -> Maybe TxStatus -> HTML a
txLink hash status = do
  a
    ! A.href (txURL hash)
    ! className "AddressURL"
    ! A.target "_blank"
    $ text $ (take 8 $ show hash ) <> "..."
  div $ text case status of
    Nothing -> ""
    Just result -> case result of
      TxPending -> "Pending..."
      TxFailed -> "Failed"
      TxOk -> "Successful"

addressURL :: Address -> String
addressURL (Address address) =
  "https://etherscan.io/address/" <> address

txURL :: TxHash -> String
txURL (TxHash hash) =
  "https://etherscan.io/tx/" <> hash

navigate :: Location -> DOMEvent -> Event
navigate location = Routing <<< Locations.Navigate location

ignoreEvent :: DOMEvent -> Event
ignoreEvent = PreventDefault Nothing

preventingDefault :: Event -> DOMEvent -> Event
preventingDefault next = PreventDefault $ Just next

onClickAction :: Event -> EventHandlers (DOMEvent -> Event)
onClickAction next = onClick $ preventingDefault next

-- | Use where result is expected to be always `Just` due to the app logic,
-- | eg. in internal store lookups
expectResult :: forall a. Maybe a -> a
expectResult a = unsafePartial $ fromJust $ a

module App.View where

import Text.Smolder.HTML hiding (address)

import App.Routing (Location(..))
import App.State (Event(..), State, signerLens)
import App.State.Contracts as Contracts
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Locations as Locations
import App.State.Signers as Signers
import Data.Array (fromFoldable)
import Data.Either (Either(..))
import Data.Lens ((^.))
import Data.Map (toUnfoldable, values)
import Data.Maybe (Maybe(..), fromJust, isJust, maybe)
import Data.String (drop, length, take, toLower)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.Eth.Contracts (class EthContract, getAddress)
import Lib.Eth.Web3 (TxHash(..), TxStatus(..))
import Lib.SignHash.Proofs.Display (SignerDisplayStatus(..), signerDisplayStatus)
import Lib.SignHash.Proofs.Methods (ProofMethod(..), canonicalName)
import Lib.SignHash.Proofs.Types (ProofState(..), ProofVerification(..))
import Lib.SignHash.Proofs.Values as ProofValues
import Lib.SignHash.Types (Address(..), HashSigner(..))
import Partial.Unsafe (unsafePartial)
import Prelude (discard, show, ($), (-), (<<<), (<>))
import Pux.DOM.Events (DOMEvent, onChange, onClick, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, src, type')
import Text.Smolder.HTML.Attributes as A
import Text.Smolder.Markup (Attribute, EventHandlers, attribute, text, (!), (#!))

foreign import images ::
  { logo :: String
  , ethIcon :: String }

dataQA :: String -> Attribute
dataQA = attribute "data-qa"

view :: State -> HTML Event
view state =
  do
    div ! className "Content" $ do
      div ! className "Header" $ do
        img ! src images.logo
        span ! className "title" $ text "SignHash"

      nav ! className "Navbar" $ do
        ul do
          li $ a ! A.href "#" #! onClick (navigate Sign) $ text "Sign"
          li $ a ! A.href "#" #! onClick (navigate Verify) $ text "Verify"

      viewContent state

      hr
      div ! className "Contracts-info" $ do
        viewContracts state.contracts
      clear

viewContent :: State -> HTML Event
viewContent state@{ location: Verify } = do
  viewFileInput "Verify" (isJust state.file)
  case state.file of
    Nothing -> empty
    Just file -> do
      viewFile file
      viewFileSigners state file
viewContent state@{ location: Sign } = do
  viewFileInput "Sign" (isJust state.file)
  case state.file of
    Nothing -> empty
    Just file -> do
      viewFile file
      sectionHeader "Your account"
      guardAccountUnlocked state.myAccount $ viewSigningDetails state file

viewFileSigners :: State -> Files.State -> HTML Event
viewFileSigners state file = do
  div $ signerStatus file.signer
  where
    signerStatus = case _ of
      Nothing -> sectionHeader "Loading signer..."
      Just (NoSigner) -> sectionHeader "No signers"
      Just (HashSigner address) -> do
        sectionHeader "Signers"
        case state ^. signerLens address of
          Nothing -> div do
            text loading
            hr
          Just value -> div do
            child (Signer address) viewSigner $ value

viewSigningDetails :: State -> Files.State -> Address -> HTML Event
viewSigningDetails state file address = do
  div ! dataQA "my-id" $ do
    let myDetails = expectResult $ state ^. signerLens address
    child (Signer address) viewSigner myDetails
    case file.result of
      Nothing -> empty
      Just fileDetails ->
        case state.signingTx of
          Nothing ->
            a
              ! A.href "#"
              ! dataQA "sign"
              #! onClickAction (SignFile fileDetails.hash)
              $ text "Sign it"
          Just (Left err) ->
            text $ "Error while issuing transaction"
          Just (Right hash) -> do
            text $ "Issued tx "
            let txStatus = Contracts.viewTxResult hash state.contracts
            txLink hash txStatus

viewContracts :: Contracts.State -> HTML Event
viewContracts Contracts.Loading =
  text $ "Loading contract..."
viewContracts (Contracts.Loaded state) = do
  contractLink "SignHash" state.signHash
  br
  contractLink "SignProof" state.signProof
  where
    contractLink :: forall c. EthContract c => String -> c -> HTML Event
    contractLink name contract = do
      span $ text $ name <> ": "
      (addressLink $ getAddress contract)
        ! dataQA ((toLower name) <> "-address")

viewContracts (Contracts.Error err) = do
  div
    ! A.title err
    $ text "Error while loading contract"

viewFileInput :: String -> Boolean -> HTML Event
viewFileInput verb small =
  div do
    label
      ! for "file-upload"
      ! className ("File-upload" <> if small then " small" else "")
      #! onDrop handleNewFiles
      #! onDragOver ignoreEvent
      $ do
        renderIcon "fa-file-o"
        text (verb <> " a file")
        if small then empty else
          div ! className "hint"
          $ text "Click or drag and drop on the page"
    input
      ! id "file-upload"
      ! type' "file"
      #! onChange handleNewFiles
  where
    handleNewFiles ev =
      preventingDefault (FileInput $ FileInputs.newFilesEvent ev) ev

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } = do
  div ! className "Files Section" $ do
    div ! className "row" $ do
      renderRow "Filename" $ text $ meta.name
      renderRow "SHA256" $ maybe (text loading) renderHash result
      renderRow "Size" $ renderSize meta.size

  where
    renderRow label value =
      div ! className "columns attribute four" $ do
        span ! className "header" $ text (label <> ":")
        span ! className "value" $ value

    renderSigner (HashSigner address) = show address
    renderSigner NoSigner = "Not signed"

    renderHash { hash } =
      let visibleOffset = 6
      in a
         ! dataQA "checksum"
         ! A.title hash
         ! A.href "#"
         $ text $ take visibleOffset hash
           <> "..."
           <> drop (length hash - visibleOffset) hash

    renderSize size = text $ show meta.size <> " B"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs, blockie } = do
  div ! className "Signer" $ do
    div ! className "header" $ do
      span ! className "status" $ do
        viewSignerStatus
    viewProofs address proofArray
    clear
  where
    proofStates = fromFoldable $ values proofs

    proofArray :: Array (Tuple ProofMethod ProofState)
    proofArray = toUnfoldable proofs

    viewSignerStatus =
      case signerDisplayStatus proofStates of
        SignerLoading -> renderIcon "fa-circle-o-notch loading"
        SignerVerified -> renderBlockie blockie
        SignerVerificationFailed -> renderIcon "fa-exclamation-circle failed"
        SignerNetworkError -> renderIcon "fa-question-circle-o network-error"

viewProofs ::
  Address
  -> Array (Tuple ProofMethod ProofState)
  -> HTML Signers.Event
viewProofs address proofs =
  div ! className "proofs" $ do
    renderEthProof
    for_ proofs renderProof
  where
    renderProof (Tuple method state) = do
      case state of
        Finished result -> renderFinishedProof method result
        NetworkError -> renderNetworkError method
        Pending -> empty

    renderFinishedProof method Unavailable = empty
    renderFinishedProof method (Unverified error) =
      div
        ! className ("proof " <> "failed")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          span ! dataQA "error" ! A.title (show error)
            $ text $ show method <> " verification failed"

    renderFinishedProof method (Verified proofValue) =
      div
        ! className ("proof " <> "verified")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          a ! A.href (methodHref method proof) ! A.target "_blank" $ text proof
      where
        proof = ProofValues.extract proofValue

    renderNetworkError method =
      div ! className ("proof" <> "network-error") $ do
        methodIcon method
        text $ "Network error while fetching proof"

    renderEthProof =
      div ! className "proof" $ do
        renderEthIcon
        (addressLink address) ! dataQA "proof-details-eth"

    methodIcon GitHub = renderIcon "fa-github"
    methodIcon HTTP = renderIcon "fa-world"

    methodHref GitHub username =
      "https://github.com/" <> username
    methodHref HTTP domain =
      "http://" <> domain

guardAccountUnlocked ::
  Contracts.ETHAccountState Address -> (Address -> HTML Event) -> HTML Event
guardAccountUnlocked state view = do
  case state of
    Contracts.Unavailable -> h4 $ text $ "Please install MetaMask extension"
    Contracts.Locked -> h4 $ text $ "Please unlock MetaMask"
    Contracts.Available address -> view address

sectionHeader :: forall a. String -> HTML a
sectionHeader msg =
  h4 ! className "Section-header" $ text msg

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa fa-lg " <> name) $ text ""

renderEthIcon :: forall a. Html a
renderEthIcon =
  img
  ! className "Icon"
  ! src images.ethIcon

renderBlockie :: forall a. String -> HTML a
renderBlockie blockieSrc =
  img ! className "blockie" ! src blockieSrc

loading :: String
loading = "Loading..."

empty :: forall a. HTML a
empty = text ""

clear :: forall a. HTML a
clear = div ! className "Clear" $ empty

addressLink :: forall a. Address -> HTML a
addressLink address = do
  a
  ! A.href (addressURL address)
  ! className "AddressURL"
  ! A.target "_blank"
  $ text $ show address

txLink :: forall a. TxHash -> Maybe TxStatus -> HTML a
txLink hash status = do
  a
    ! A.href (txURL hash)
    ! className "AddressURL"
    ! A.target "_blank"
    $ text $ (take 8 $ show hash ) <> "..."
  div $ text case status of
    Nothing -> ""
    Just result -> case result of
      TxPending -> "Pending..."
      TxFailed -> "Failed"
      TxOk -> "Successful"

addressURL :: Address -> String
addressURL (Address address) =
  "https://etherscan.io/address/" <> address

txURL :: TxHash -> String
txURL (TxHash hash) =
  "https://etherscan.io/tx/" <> hash

navigate :: Location -> DOMEvent -> Event
navigate location = Routing <<< Locations.Navigate location

ignoreEvent :: DOMEvent -> Event
ignoreEvent = PreventDefault Nothing

preventingDefault :: Event -> DOMEvent -> Event
preventingDefault next = PreventDefault $ Just next

onClickAction :: Event -> EventHandlers (DOMEvent -> Event)
onClickAction next = onClick $ preventingDefault next

-- | Use where result is expected to be always `Just` due to the app logic,
-- | eg. in internal store lookups
expectResult :: forall a. Maybe a -> a
expectResult a = unsafePartial $ fromJust $ a