[SD-1359] Quasar.Aff: don't ever retry based on status code

- retryGet: don't retry based on status code
- listing: use retryGet
- various whitespace style adjustments

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Quasar.Aff
  ( children
  , mountInfo
  , move
  , reqHeadersToJSON
  , saveMount
  , delete
  , getNewName
  , makeFile
  , ldJSON
  , getVersion

  , fields
  , templated
  , forceDelete
  , executeQuery
  , all
  , sample
  , transitiveChildrenProducer
  , query'
  , count

  , save
  , load
  , resourceExists
  , RetryEffects()
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply (lift2)
import Control.Bind ((>=>), (<=<), (=<<))
import Control.Coroutine as CR
import Control.Coroutine.Aff as ACR
import Control.Monad (when)
import Control.Monad.Aff (Aff(), attempt, runAff)
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Eff.Ref (REF(), newRef, readRef, modifyRef)
import Control.Monad.Error.Class (MonadError, throwError)
import Control.MonadPlus (guard)
import Control.UI.Browser (encodeURIComponent)

import Data.Argonaut ((~>), (:=), (.?))
import Data.Argonaut as JS
import Data.Array as Arr
import Data.Bifunctor (bimap, lmap)
import Data.Date as Date
import Data.Either (Either(..), either, isRight)
import Data.Foldable (foldl, for_, traverse_)
import Data.Foreign (F(), parseJSON)
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign.Index (prop)
import Data.Foreign.NullOrUndefined (runNullOrUndefined)
import Data.Functor (($>))
import Data.Functor.Eff (liftEff)
import Data.Lens ((.~), (^.))
import Data.List as L
import Data.Maybe (Maybe(..), isJust, fromMaybe, maybe)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.Set as Set
import Data.String as S
import Data.StrMap as SM
import Data.Time (Milliseconds(..))
import Data.Tuple (Tuple(..))

import DOM (DOM())

import Network.HTTP.Affjax (Affjax(), AJAX(), AffjaxRequest(), AffjaxResponse(), RetryPolicy(), defaultRequest, affjax, retry, defaultRetryPolicy)
import Network.HTTP.Affjax.Request (Requestable)
import Network.HTTP.Affjax.Response (Respondable, ResponseType(JSONResponse))
import Network.HTTP.Method (Method(..))
import Network.HTTP.MimeType (MimeType(..), mimeTypeToString)
import Network.HTTP.MimeType.Common (applicationJSON)
import Network.HTTP.RequestHeader (RequestHeader(..))
import Network.HTTP.StatusCode (StatusCode(..))

import Quasar.Paths as Paths

-- TODO: split out a core Quasar module that only deals with the API, and
-- doesn't know about SlamData specific things.
import SlamData.Config as Config
import SlamData.FileSystem.Resource as R

import Utils.Completions (memoizeCompletionStrs)
import Utils.Path as PU

newtype Listing = Listing (Array R.Resource)

runListing :: Listing -> Array R.Resource
runListing (Listing rs) = rs

instance listingIsForeign :: IsForeign Listing where
  read f =
    read f
      >>= readProp "children"
      >>= pure
        <<< Listing
        <<< fromMaybe []
        <<< runNullOrUndefined

instance listingRespondable :: Respondable Listing where
  responseType = Tuple (Just applicationJSON) JSONResponse
  fromResponse = read

children
  :: forall e
   . PU.DirPath
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e)) (Array R.Resource)
children dir = do
  cs <- children' dir
  let result = (R._root .~ dir) <$> cs
  memoizeCompletionStrs dir result
  pure result

children'
  :: forall e
   . PU.DirPath -> Aff (RetryEffects (ajax :: AJAX | e)) (Array R.Resource)
children' dir = runListing <$> (getResponse msg $ listing dir)
  where
  msg = "Error: can not get children of resource"

listing :: forall e. PU.DirPath -> Affjax (RetryEffects e) Listing
listing p =
  case P.relativeTo p P.rootDir of
    Nothing -> throwError $ Exn.error "incorrect path"
    Just p ->
      retryGet
        (Paths.metadataUrl </> p)
        applicationJSON

makeFile
  :: forall e
   . PU.FilePath
   -> MimeType
   -> String
   -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
makeFile path mime content =
  getResponse msg go
  where
  msg :: String
  msg = "error while creating file"

  firstLine :: Maybe String
  firstLine = Arr.head $ S.split "\n" content

  isJson :: Either String JS.Json
  isJson = maybe (Left "empty file") Right firstLine >>= JS.jsonParser

  go :: Aff (RetryEffects (ajax :: AJAX | e)) (AffjaxResponse Unit)
  go = slamjax $ defaultRequest
   { method = PUT
   , headers = [ ContentType mime ]
   , content = Just content
   , url = fromMaybe "" $ (P.printPath <<< (Paths.dataUrl </>)) <$> P.relativeTo path P.rootDir
   }

successStatus :: StatusCode
successStatus = StatusCode 200

notFoundStatus :: StatusCode
notFoundStatus = StatusCode 404

succeeded :: StatusCode -> Boolean
succeeded (StatusCode int) =
  200 <= code && code < 300
  where code = int

type RetryEffects e = (avar :: AVAR, ref :: REF, now :: Date.Now | e)

-- | A version of `affjax` with our retry policy.
slamjax
  :: forall e a b
   . (Requestable a, Respondable b)
  => AffjaxRequest a
  -> Affjax (RetryEffects e) b
slamjax =
  retry
    defaultRetryPolicy
    affjax

retryGet
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
retryGet =
  getWithPolicy $
    defaultRetryPolicy
      { delayCurve = const 1000
      , timeout = Just 30000
      }

mkRequest
  :: forall e fd
   . P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Aff (RetryEffects e) (AffjaxRequest Unit)
mkRequest u mime = do
  nocache <- liftEff $ Date.nowEpochMilliseconds
  pure $
    defaultRequest
      { url = url' nocache
      , headers = [ Accept mime ]
      }
  where
  url' nocache = url <> symbol <> "nocache=" <> pretty nocache
  symbol = if S.contains "?" url then "&" else "?"
  pretty (Milliseconds ms) = let s = show ms in fromMaybe s (S.stripSuffix ".0" s)
  url = P.printPath u

getOnce
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
getOnce u mime =
  mkRequest u mime
    >>= affjax

getWithPolicy
  :: forall e a fd
   . (Respondable a)
  => RetryPolicy
  -> P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
getWithPolicy policy u mime =
  mkRequest u mime
    >>= retry policy affjax

retryDelete
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed
  -> Affjax (RetryEffects e) a
retryDelete u = do
  slamjax $ defaultRequest
    { url = P.printPath u
    , method = DELETE
    }

retryPost
  :: forall e a b fd
   . (Requestable a, Respondable b)
  => P.Path P.Abs fd P.Sandboxed -> a -> Affjax (RetryEffects e) b
retryPost u c =
  slamjax $ defaultRequest
    { method = POST
    , url = P.printPath u
    , content = Just c
    }

retryPut
  :: forall e a b fd
   . (Requestable a, Respondable b)
  => P.Path P.Abs fd P.Sandboxed -> a -> MimeType -> Affjax (RetryEffects e) b
retryPut u c mime =
  slamjax $ defaultRequest
    { method = PUT
    , url = P.printPath u
    , content = Just c
    , headers = [ContentType mime]
    }

getResponse :: forall a e. String -> Affjax e a -> Aff (ajax :: AJAX | e) a
getResponse msg affjax = do
  res <- attempt affjax
  case res of
    Left e -> throwError $ Exn.error msg
    Right r -> do
      if not $ succeeded r.status
        then throwError $ Exn.error msg
        else pure r.response

reqHeadersToJSON :: Array RequestHeader -> JS.Json
reqHeadersToJSON = foldl go JS.jsonEmptyObject
  where
  go obj (Accept mime) = "Accept" := mimeTypeToString mime ~> obj
  go obj (ContentType mime) = "Content-Type" := mimeTypeToString mime ~> obj
  go obj (RequestHeader k v) = k := v ~> obj

mountInfo :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) String
mountInfo res = do
  result <- getOnce mountPath applicationJSON
  if succeeded result.status
     then case parse result.response of
       Left err ->
         throwError $ Exn.error (show err)
       Right uri ->
         pure uri
     else throwError (Exn.error result.response)

  where
  mountPath :: P.Path P.Abs P.Dir P.Sandboxed
  mountPath =
    (Paths.mountUrl </> PU.rootify (R.resourceDir res)) #
      if R.resourceName res == ""
        then id
        else (</> (P.dir (R.resourceName res)))

  parse :: String -> F String
  parse = parseJSON >=> prop "mongodb" >=> readProp "connectionUri"

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  :: forall e. PU.DirPath -> String -> Aff (RetryEffects (ajax :: AJAX |e)) String
getNewName parent name = do
  items <- attempt (children' parent) <#> either (const []) id
  pure if exists' name items then getNewName' items 1 else name
  where
  getNewName' items i =
    let arr = S.split "." name
    in fromMaybe "" do
      body <- Arr.head arr
      suffixes <- Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists' newName items
           then getNewName' items (i + one)
           else newName

exists' :: String -> Array R.Resource -> Boolean
exists' name items = isJust $ Arr.findIndex (\r -> r ^. R._name == name) items

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  :: forall e
   . R.Resource
  -> PU.AnyPath
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) (Maybe PU.AnyPath)
move src tgt = do
  let url = if R.isDatabase src || R.isViewMount src
            then Paths.mountUrl
            else Paths.dataUrl
  cleanViewMounts src
  result <- affjax $ defaultRequest
    { method = MOVE
    , headers = [RequestHeader "Destination" $ either P.printPath P.printPath tgt]
    , url =
        either
          (P.printPath <<< (url </>) <<< PU.rootifyFile)
          (P.printPath <<< (url </>) <<< PU.rootify)
          (R.getPath src)
    }
  if succeeded result.status
    then pure $ Just tgt
    else if result.status == notFoundStatus
      then pure Nothing
      else throwError (Exn.error result.response)

saveMount
  :: forall e
   . R.Resource
  -> String
  -> Aff (RetryEffects (ajax :: AJAX |e)) Unit
saveMount res uri = do
  result <- slamjax $ defaultRequest
    { method = PUT
    , headers = [ ContentType applicationJSON ]
    , content = Just $ stringify { mongodb: {connectionUri: uri } }
    , url = P.printPath
            $ Paths.mountUrl
            </> PU.rootify (R.resourceDir res)
            </> P.dir (R.resourceName res)
    }
  if succeeded result.status
    then pure unit
    else throwError (Exn.error result.response)

foreign import stringify :: forall r. {|r} -> String

delete
  :: forall e
   . R.Resource
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) (Maybe R.Resource)
delete resource =
  if not (R.isDatabase resource || alreadyInTrash resource || R.isViewMount resource)
  then (moveToTrash resource) <|> (forceDelete resource $> Nothing)
  else forceDelete resource $> Nothing

  where
  msg :: String
  msg = "cannot delete"

  moveToTrash
    :: R.Resource
    -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e)) (Maybe R.Resource)
  moveToTrash res = do
    let d = (res ^. R._root) </> P.dir Config.trashFolder
        path = (res # R._root .~ d) ^. R._path
    name <- getNewName d (res ^. R._name)
    move res (path # R._nameAnyPath .~ name)
    pure (Just $ R.Directory d)

  alreadyInTrash :: R.Resource -> Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left _ -> alreadyInTrash' (res ^. R._root)
      Right path -> alreadyInTrash' path

  alreadyInTrash' :: PU.DirPath -> Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

  go :: Tuple PU.DirPath (Either P.DirName P.FileName) -> Boolean
  go (Tuple d name) =
    case name of
      Right _ -> false
      Left n ->
        if n == P.DirName Config.trashFolder
        then true
        else alreadyInTrash' d

forceDelete
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) Unit
forceDelete res = do
  cleanViewMounts res
  getResponse "cannot delete"
    $  either retryDelete retryDelete
    $  pathFromResource res

  where
  pathFromResource :: R.Resource -> PU.AnyPath
  pathFromResource r = transplant (rootForResource r) (R.getPath r)

  transplant :: PU.DirPath -> PU.AnyPath -> PU.AnyPath
  transplant newRoot =
    bimap
      (\p -> newRoot </> PU.rootifyFile p)
      (\p -> newRoot </> PU.rootify p)

  rootForResource :: R.Resource -> PU.DirPath
  rootForResource r =
    if R.isDatabase r || R.isViewMount r
    then Paths.mountUrl
    else Paths.dataUrl

cleanViewMounts
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM|e)) Unit
cleanViewMounts res = for_ (R.getPath res) \dirPath ->
  children dirPath >>= Arr.filter R.isViewMount >>> traverse_ forceDelete

getVersion :: forall e. Aff (RetryEffects (ajax :: AJAX |e)) (Maybe String)
getVersion = do
  serverInfo <- retryGet Paths.serverInfoUrl applicationJSON
  return $ either (const Nothing) Just (readProp "version" serverInfo.response)

ldJSON :: MimeType
ldJSON = MimeType "application/ldjson"

-- | Produces a stream of the transitive children of a path
transitiveChildrenProducer
  :: forall e
   . PU.DirPath
  -> CR.Producer
      (Array R.Resource)
      (Aff (RetryEffects (ajax :: AJAX, err :: Exn.EXCEPTION, dom :: DOM | e)))
      Unit
transitiveChildrenProducer dirPath = do
  ACR.produce \emit -> do
    activeRequests <- newRef $ Set.singleton $ P.printPath dirPath
    runAff Exn.throwException (const (pure unit)) $ go emit activeRequests dirPath
  where
  go emit activeRequests start = do
    let strPath = P.printPath start
    eitherChildren <- attempt $ children start
    liftEff $ modifyRef activeRequests $ Set.delete strPath
    for_ eitherChildren \items -> do
      liftEff $ emit $ Left items
      let parents = Arr.mapMaybe (either (const Nothing) Just <<< R.getPath) items
      for_ parents $ \p ->
        liftEff $ modifyRef activeRequests $ Set.insert $ P.printPath p
      for_ parents $ go emit activeRequests
    remainingRequests <- liftEff $ readRef activeRequests
    if Set.isEmpty remainingRequests
      then liftEff $ emit $ Right unit
      else pure unit

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query
  :: forall e. R.Resource -> SQL -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
query res sql =
  if not $ R.isFile res
  then pure []
  else extractJArray =<< getResponse msg (getOnce uriPath applicationJSON)
  where
  msg = "error in query"
  uriPath = mkURI res sql

query'
  :: forall e
   . R.Resource -> SQL
  -> Aff (RetryEffects (ajax :: AJAX | e)) (Either String JS.JArray)
query' res@(R.File _) sql = do
  result <- retryGet (mkURI' res sql) applicationJSON
  pure if succeeded result.status
       then JS.decodeJson <=< JS.jsonParser $ result.response
       else Left $ readError "error in query" result.response

query' _ _ = pure $ Left "Query resource is not a file"

count :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) Int
count res = do
  result <- getOnce uriPath applicationJSON
  when (not $ succeeded result.status) raiseError
  -- See SD-1331. If user requests `count` for incorrect sql-mount
  -- it returns "[" --> throwError is used to mark non-existent and
  -- incorrect resources here.
  maybe raiseError pure $
    (JS.jsonParser result.response # either (const Nothing) Just)
    >>= JS.toArray
    >>= Arr.head
    >>= JS.toObject
    >>= SM.lookup "total"
    >>= JS.toNumber
    >>= Data.Int.fromNumber
  where
  raiseError :: forall a. Aff (RetryEffects (ajax :: AJAX |e)) a
  raiseError = throwError $ Exn.error "count query returned incorrect json"

  uriPath :: P.Path P.Abs P.File P.Sandboxed
  uriPath = mkURI res sql

  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

resourceExists :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX|e)) Boolean
resourceExists res = map isRight $ attempt $ count res

portView
  :: forall e
   . R.Resource
  -> R.Resource
  -> SQL
  -> SM.StrMap String
  -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
portView res dest sql varMap = do
  guard $ R.isFile dest
  let
    queryParams = maybe "" ("&" <>) $ renderQueryString varMap
    connectionUri = "sql2:///?q="
                    <> PU.encodeURIPath (templated res sql)
                    <> queryParams
  result <-
    slamjax $ defaultRequest
      { method = PUT
      , headers = [ ContentType applicationJSON ]
      , content = Just $ stringify { view: { connectionUri: connectionUri } }
      , url =
          P.printPath $
            Paths.mountUrl
              </> PU.rootify (R.resourceDir dest)
              </> P.file (R.resourceName dest)
      }
  if succeeded result.status
     then pure unit
     else throwError $ Exn.error $ readError result.response result.response

portQuery
  :: forall e
   . R.Resource
  -> R.Resource
  -> SQL
  -> SM.StrMap String
  -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JObject
portQuery res dest sql vars = do
  guard $ R.isFile dest
  result <-
    slamjax $ defaultRequest
      { method = POST
      , headers =
          [ RequestHeader "Destination" $ R.resourcePath dest
          , ContentType ldJSON
          ]
      , url =
          P.printPath $
            Paths.queryUrl
              </> PU.rootify (R.resourceDir res)
              </> P.dir (R.resourceName res)
              </> P.file queryVars
      , content = Just (templated res sql)
      }

  if not $ succeeded result.status
    then throwError $ Exn.error $ readError result.response result.response
    else
    -- We expect result message to be valid json.
    either (throwError <<< Exn.error) pure $
      JS.jsonParser result.response >>= JS.decodeJson
  where
  queryVars :: String
  queryVars = maybe "" ("?" <>) $ renderQueryString vars

renderQueryString :: SM.StrMap String -> Maybe String
renderQueryString = map go <<< L.uncons <<< SM.toList
  where
  pair :: Tuple String String -> String
  pair (Tuple a b) = "var." <> a <> "=" <> encodeURIComponent b

  go { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) (pair h) t

readError :: String -> String -> String
readError msg input =
  let responseError = JS.jsonParser input >>= JS.decodeJson >>= (.? "error")
  in either (const msg) id responseError

sample'
  :: forall e
   . R.Resource -> Maybe Int -> Maybe Int
   -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
sample' res mbOffset mbLimit =
  if not $ R.isFile res
  then pure []
  else extractJArray =<< getResponse msg (retryGet uri applicationJSON)
  where
  msg = "error getting resource sample"
  uri =
    Paths.dataUrl
      </> PU.rootify (R.resourceDir res)
      </> P.file
            (R.resourceName res
               <> (maybe "" (("?offset=" <>) <<< show) mbOffset)
               <> (maybe "" (("&limit=" <>) <<< show ) mbLimit))

sample
  :: forall e
   . R.Resource -> Int -> Int -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
sample res offset limit = sample' res (Just offset) (Just limit)

all :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
all res = sample' res Nothing Nothing

fields
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) (Array String)
fields res = do
  jarr <- sample res 0 100
  case jarr of
    [] -> throwError $ Exn.error "empty file"
    _ -> pure $ Arr.nub $ Arr.concat (getFields <$> jarr)

mkURI :: R.Resource -> SQL -> PU.FilePath
mkURI res sql =
  Paths.queryUrl </> P.file ("?q=" <> encodeURIComponent (templated res sql))

mkURI' :: R.Resource -> SQL -> PU.FilePath
mkURI' res sql =
  Paths.queryUrl
  </> PU.rootify (R.resourceDir res)
  </> P.dir (R.resourceName res)
  </> P.file ("?q=" <> encodeURIComponent (templated res sql))

templated :: R.Resource -> SQL -> SQL
templated res = S.replace "{{path}}" ("\"" <> R.resourcePath res <> "\"")

extractJArray :: forall m. (MonadError Exn.Error m) => JS.Json -> m JS.JArray
extractJArray = either (throwError <<< Exn.error) pure <<< JS.decodeJson

getFields :: JS.Json -> Array String
getFields json = Arr.filter (/= "") $ Arr.nub $ getFields' [] json

getFields' :: Array String -> JS.Json -> Array String
getFields' [] json = getFields' [""] json
getFields' acc json =
  if JS.isObject json
  then maybe acc (goObj acc) $ JS.toObject json
  else if JS.isArray json
       then maybe acc (goArr acc) $ JS.toArray json
       else acc

  where
  goArr :: Array String -> JS.JArray -> Array String
  goArr acc arr =
    Arr.concat $ getFields' (lift2 append acc $ mkArrIxs arr) <$> arr
    where
    mkArrIxs :: JS.JArray -> Array String
    mkArrIxs jarr =
      map (show >>> \x -> "[" <> x <> "]") $ Arr.range 0 $ Arr.length jarr - 1

  goObj :: Array String -> JS.JObject -> Array String
  goObj acc = Arr.concat <<< map (goTuple acc) <<< L.fromList <<< SM.toList

  goTuple :: Array String -> Tuple String JS.Json -> Array String
  goTuple acc (Tuple key json) =
    getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json

executeQuery
  :: forall e
   . String
  -> Boolean
  -> SM.StrMap String
  -> R.Resource
  -> R.Resource
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e))
      (Either String { outputResource :: R.Resource, plan :: Maybe String })
executeQuery sql cachingEnabled varMap inputResource outputResource = do
  when (R.isTempFile outputResource) $
    void $ attempt $ forceDelete outputResource

  ejobj <- do
    attempt $
      if cachingEnabled
         then portQuery inputResource outputResource sql varMap <#> Just
         else portView inputResource outputResource sql varMap $> Nothing

  pure $ do
    mjobj <- lmap Exn.message ejobj
    info <-
      case mjobj of
        Nothing -> do
          path <- R.getPath outputResource # either pure \_ ->
            Left "Expected output resource as file or view mount"
          sandboxedPath <- P.sandbox P.rootDir path
                           # maybe (Left "Could not sandbox output resource") pure
          pure
            { sandboxedPath
            , plan: Nothing
            }
        Just jobj -> do
          planPhases <- Arr.last <$> jobj .? "phases"
          sandboxedPath <- do
            pathString <- jobj .? "out"
            path <- P.parseAbsFile pathString
                    # maybe (Left "Invalid file from Quasar") pure
            P.sandbox P.rootDir path
              # maybe (Left "Could not sandbox Quasar file") pure
          pure
            { sandboxedPath
            , plan: planPhases >>= (.? "detail") >>> either (const Nothing) Just
            }
    pure
      { outputResource: R.mkFile $ Left $ P.rootDir </> info.sandboxedPath
      , plan: info.plan
      }

-- | Saves a JSON value to a file.
-- |
-- | Even though the path is expected to be absolute it should not include the
-- | `/data/fs` part of the path for the API.
save
  :: forall e
   . PU.FilePath
  -> JS.Json
  -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
save path json =
  let apiPath = Paths.dataUrl </> PU.rootifyFile path
  in getResponse "error while saving file" (retryPut apiPath json ldJSON)

-- | Loads a JSON value from a file.
-- |
-- | Even though the path is expected to be absolute it should not include the
-- | `/data/fs` part of the path for the API.
load
  :: forall e
   . PU.FilePath
  -> Aff (RetryEffects (ajax :: AJAX | e)) (Either String JS.Json)
load path =
  let apiPath = Paths.dataUrl </> PU.rootifyFile path
  in lmap Exn.message <$> attempt (getResponse "error loading notebook" (retryGet apiPath ldJSON))

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Quasar.Aff
  ( children
  , mountInfo
  , move
  , reqHeadersToJSON
  , saveMount
  , delete
  , getNewName
  , makeFile
  , ldJSON
  , getVersion

  , fields
  , templated
  , forceDelete
  , executeQuery
  , all
  , sample
  , transitiveChildrenProducer
  , query'
  , count

  , save
  , load
  , resourceExists
  , RetryEffects()
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply (lift2)
import Control.Bind ((>=>), (<=<), (=<<))
import Control.Coroutine as CR
import Control.Coroutine.Aff as ACR
import Control.Monad (when)
import Control.Monad.Aff (Aff(), attempt, runAff)
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Eff.Ref (REF(), newRef, readRef, modifyRef)
import Control.Monad.Error.Class (MonadError, throwError)
import Control.MonadPlus (guard)
import Control.UI.Browser (encodeURIComponent)

import Data.Argonaut ((~>), (:=), (.?))
import Data.Argonaut as JS
import Data.Array as Arr
import Data.Bifunctor (bimap, lmap)
import Data.Date as Date
import Data.Either (Either(..), either, isRight)
import Data.Foldable (foldl, for_, traverse_)
import Data.Foreign (F(), parseJSON)
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign.Index (prop)
import Data.Foreign.NullOrUndefined (runNullOrUndefined)
import Data.Functor (($>))
import Data.Functor.Eff (liftEff)
import Data.Lens ((.~), (^.))
import Data.List as L
import Data.Maybe (Maybe(..), isJust, fromMaybe, maybe)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.Set as Set
import Data.String as S
import Data.StrMap as SM
import Data.Time (Milliseconds(..))
import Data.Tuple (Tuple(..))

import DOM (DOM())

import Network.HTTP.Affjax (Affjax(), AJAX(), AffjaxRequest(), AffjaxResponse(), RetryPolicy(), defaultRequest, affjax, retry, defaultRetryPolicy)
import Network.HTTP.Affjax.Request (Requestable)
import Network.HTTP.Affjax.Response (Respondable, ResponseType(JSONResponse))
import Network.HTTP.Method (Method(..))
import Network.HTTP.MimeType (MimeType(..), mimeTypeToString)
import Network.HTTP.MimeType.Common (applicationJSON)
import Network.HTTP.RequestHeader (RequestHeader(..))
import Network.HTTP.StatusCode (StatusCode(..))

import Quasar.Paths as Paths

-- TODO: split out a core Quasar module that only deals with the API, and
-- doesn't know about SlamData specific things.
import SlamData.Config as Config
import SlamData.FileSystem.Resource as R

import Utils.Completions (memoizeCompletionStrs)
import Utils.Path as PU

newtype Listing = Listing (Array R.Resource)

runListing :: Listing -> Array R.Resource
runListing (Listing rs) = rs

instance listingIsForeign :: IsForeign Listing where
  read f =
    read f
      >>= readProp "children"
      >>= pure
        <<< Listing
        <<< fromMaybe []
        <<< runNullOrUndefined

instance listingRespondable :: Respondable Listing where
  responseType = Tuple (Just applicationJSON) JSONResponse
  fromResponse = read

children
  :: forall e
   . PU.DirPath
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e)) (Array R.Resource)
children dir = do
  cs <- children' dir
  let result = (R._root .~ dir) <$> cs
  memoizeCompletionStrs dir result
  pure result

children'
  :: forall e
   . PU.DirPath -> Aff (RetryEffects (ajax :: AJAX | e)) (Array R.Resource)
children' dir = runListing <$> (getResponse msg $ listing dir)
  where
  msg = "Error: can not get children of resource"

listing :: forall e. PU.DirPath -> Affjax (RetryEffects e) Listing
listing p =
  case P.relativeTo p P.rootDir of
    Nothing -> throwError $ Exn.error "incorrect path"
    Just p ->
      getWithPolicy
        { shouldRetryWithStatusCode: \c -> not (succeeded c || c == notFoundStatus)
        , delayCurve: const 1000
        , timeout: Just 10000
        }
        (Paths.metadataUrl </> p)
        applicationJSON

makeFile
  :: forall e
   . PU.FilePath
   -> MimeType
   -> String
   -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
makeFile path mime content =
  getResponse msg go
  where
  msg :: String
  msg = "error while creating file"

  firstLine :: Maybe String
  firstLine = Arr.head $ S.split "\n" content

  isJson :: Either String JS.Json
  isJson = maybe (Left "empty file") Right firstLine >>= JS.jsonParser

  go :: Aff (RetryEffects (ajax :: AJAX | e)) (AffjaxResponse Unit)
  go = slamjax $ defaultRequest
   { method = PUT
   , headers = [ ContentType mime ]
   , content = Just content
   , url = fromMaybe "" $ (P.printPath <<< (Paths.dataUrl </>)) <$> P.relativeTo path P.rootDir
   }

successStatus :: StatusCode
successStatus = StatusCode 200

notFoundStatus :: StatusCode
notFoundStatus = StatusCode 404

succeeded :: StatusCode -> Boolean
succeeded (StatusCode int) =
  200 <= code && code < 300
  where code = int

type RetryEffects e = (avar :: AVAR, ref :: REF, now :: Date.Now | e)

-- | A version of `affjax` with our retry policy.
slamjax
  :: forall e a b
   . (Requestable a, Respondable b)
  => AffjaxRequest a -> Affjax (RetryEffects e) b
slamjax = retry defaultRetryPolicy affjax

retryGet
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
retryGet =
  getWithPolicy
    { shouldRetryWithStatusCode: not <<< succeeded
    , delayCurve: const 1000
    , timeout: Just 30000
    }

mkRequest
  :: forall e fd
   . P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Aff (RetryEffects e) (AffjaxRequest Unit)
mkRequest u mime = do
  nocache <- liftEff $ Date.nowEpochMilliseconds
  pure $ defaultRequest { url = url' nocache
                        , headers = [ Accept mime ]
                        }
  where
  url' nocache = url <> symbol <> "nocache=" <> pretty nocache
  symbol = if S.contains "?" url then "&" else "?"
  pretty (Milliseconds ms) = let s = show ms in fromMaybe s (S.stripSuffix ".0" s)
  url = P.printPath u

getOnce
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
getOnce u mime = mkRequest u mime >>= affjax

getWithPolicy
  :: forall e a fd
   . (Respondable a)
  => RetryPolicy
  -> P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
getWithPolicy policy u mime = mkRequest u mime >>= retry policy affjax

retryDelete
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed -> Affjax (RetryEffects e) a
retryDelete u =
  slamjax $ defaultRequest { url = P.printPath u, method = DELETE }

retryPost
  :: forall e a b fd
   . (Requestable a, Respondable b)
  => P.Path P.Abs fd P.Sandboxed -> a -> Affjax (RetryEffects e) b
retryPost u c =
  slamjax $ defaultRequest { method = POST, url = P.printPath u, content = Just c }

retryPut
  :: forall e a b fd
   . (Requestable a, Respondable b)
  => P.Path P.Abs fd P.Sandboxed -> a -> MimeType -> Affjax (RetryEffects e) b
retryPut u c mime =
  slamjax $ defaultRequest
    { method = PUT
    , url = P.printPath u
    , content = Just c
    , headers = [ContentType mime]
    }

getResponse :: forall a e. String -> Affjax e a -> Aff (ajax :: AJAX | e) a
getResponse msg affjax = do
  res <- attempt affjax
  case res of
    Left e -> throwError $ Exn.error msg
    Right r -> do
      if not $ succeeded r.status
        then throwError $ Exn.error msg
        else pure r.response

reqHeadersToJSON :: Array RequestHeader -> JS.Json
reqHeadersToJSON = foldl go JS.jsonEmptyObject
  where
  go obj (Accept mime) = "Accept" := mimeTypeToString mime ~> obj
  go obj (ContentType mime) = "Content-Type" := mimeTypeToString mime ~> obj
  go obj (RequestHeader k v) = k := v ~> obj

mountInfo :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) String
mountInfo res = do
  result <- getOnce mountPath applicationJSON
  if succeeded result.status
     then case parse result.response of
       Left err ->
         throwError $ Exn.error (show err)
       Right uri ->
         pure uri
     else throwError (Exn.error result.response)

  where
  mountPath :: P.Path P.Abs P.Dir P.Sandboxed
  mountPath =
    (Paths.mountUrl </> PU.rootify (R.resourceDir res)) #
      if R.resourceName res == ""
        then id
        else (</> (P.dir (R.resourceName res)))

  parse :: String -> F String
  parse = parseJSON >=> prop "mongodb" >=> readProp "connectionUri"

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  :: forall e. PU.DirPath -> String -> Aff (RetryEffects (ajax :: AJAX |e)) String
getNewName parent name = do
  items <- attempt (children' parent) <#> either (const []) id
  pure if exists' name items then getNewName' items 1 else name
  where
  getNewName' items i =
    let arr = S.split "." name
    in fromMaybe "" do
      body <- Arr.head arr
      suffixes <- Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists' newName items
           then getNewName' items (i + one)
           else newName

exists' :: String -> Array R.Resource -> Boolean
exists' name items = isJust $ Arr.findIndex (\r -> r ^. R._name == name) items

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  :: forall e
   . R.Resource
  -> PU.AnyPath
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) (Maybe PU.AnyPath)
move src tgt = do
  let url = if R.isDatabase src || R.isViewMount src
            then Paths.mountUrl
            else Paths.dataUrl
  cleanViewMounts src
  result <- affjax $ defaultRequest
    { method = MOVE
    , headers = [RequestHeader "Destination" $ either P.printPath P.printPath tgt]
    , url =
        either
          (P.printPath <<< (url </>) <<< PU.rootifyFile)
          (P.printPath <<< (url </>) <<< PU.rootify)
          (R.getPath src)
    }
  if succeeded result.status
    then pure $ Just tgt
    else if result.status == notFoundStatus
      then pure Nothing
      else throwError (Exn.error result.response)

saveMount
  :: forall e. R.Resource -> String -> Aff (RetryEffects (ajax :: AJAX |e)) Unit
saveMount res uri = do
  result <- slamjax $ defaultRequest
    { method = PUT
    , headers = [ ContentType applicationJSON ]
    , content = Just $ stringify { mongodb: {connectionUri: uri } }
    , url = P.printPath
            $ Paths.mountUrl
            </> PU.rootify (R.resourceDir res)
            </> P.dir (R.resourceName res)
    }
  if succeeded result.status
    then pure unit
    else throwError (Exn.error result.response)

foreign import stringify :: forall r. {|r} -> String

delete
  :: forall e
   . R.Resource
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) (Maybe R.Resource)
delete resource =
  if not (R.isDatabase resource || alreadyInTrash resource || R.isViewMount resource)
  then (moveToTrash resource) <|> (forceDelete resource $> Nothing)
  else forceDelete resource $> Nothing

  where
  msg :: String
  msg = "cannot delete"

  moveToTrash
    :: R.Resource
    -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e)) (Maybe R.Resource)
  moveToTrash res = do
    let d = (res ^. R._root) </> P.dir Config.trashFolder
        path = (res # R._root .~ d) ^. R._path
    name <- getNewName d (res ^. R._name)
    move res (path # R._nameAnyPath .~ name)
    pure (Just $ R.Directory d)

  alreadyInTrash :: R.Resource -> Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left _ -> alreadyInTrash' (res ^. R._root)
      Right path -> alreadyInTrash' path

  alreadyInTrash' :: PU.DirPath -> Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

  go :: Tuple PU.DirPath (Either P.DirName P.FileName) -> Boolean
  go (Tuple d name) =
    case name of
      Right _ -> false
      Left n ->
        if n == P.DirName Config.trashFolder
        then true
        else alreadyInTrash' d

forceDelete
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) Unit
forceDelete res = do
  cleanViewMounts res
  getResponse "cannot delete"
    $  either retryDelete retryDelete
    $  pathFromResource res

  where
  pathFromResource :: R.Resource -> PU.AnyPath
  pathFromResource r = transplant (rootForResource r) (R.getPath r)

  transplant :: PU.DirPath -> PU.AnyPath -> PU.AnyPath
  transplant newRoot =
    bimap
      (\p -> newRoot </> PU.rootifyFile p)
      (\p -> newRoot </> PU.rootify p)

  rootForResource :: R.Resource -> PU.DirPath
  rootForResource r =
    if R.isDatabase r || R.isViewMount r
    then Paths.mountUrl
    else Paths.dataUrl

cleanViewMounts
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM|e)) Unit
cleanViewMounts res = for_ (R.getPath res) \dirPath ->
  children dirPath >>= Arr.filter R.isViewMount >>> traverse_ forceDelete

getVersion :: forall e. Aff (RetryEffects (ajax :: AJAX |e)) (Maybe String)
getVersion = do
  serverInfo <- retryGet Paths.serverInfoUrl applicationJSON
  return $ either (const Nothing) Just (readProp "version" serverInfo.response)

ldJSON :: MimeType
ldJSON = MimeType "application/ldjson"

-- | Produces a stream of the transitive children of a path
transitiveChildrenProducer
  :: forall e
   . PU.DirPath
  -> CR.Producer
      (Array R.Resource)
      (Aff (RetryEffects (ajax :: AJAX, err :: Exn.EXCEPTION, dom :: DOM | e)))
      Unit
transitiveChildrenProducer dirPath = do
  ACR.produce \emit -> do
    activeRequests <- newRef $ Set.singleton $ P.printPath dirPath
    runAff Exn.throwException (const (pure unit)) $ go emit activeRequests dirPath
  where
  go emit activeRequests start = do
    let strPath = P.printPath start
    eitherChildren <- attempt $ children start
    liftEff $ modifyRef activeRequests $ Set.delete strPath
    for_ eitherChildren \items -> do
      liftEff $ emit $ Left items
      let parents = Arr.mapMaybe (either (const Nothing) Just <<< R.getPath) items
      for_ parents $ \p ->
        liftEff $ modifyRef activeRequests $ Set.insert $ P.printPath p
      for_ parents $ go emit activeRequests
    remainingRequests <- liftEff $ readRef activeRequests
    if Set.isEmpty remainingRequests
      then liftEff $ emit $ Right unit
      else pure unit

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query
  :: forall e. R.Resource -> SQL -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
query res sql =
  if not $ R.isFile res
  then pure []
  else extractJArray =<< getResponse msg (getOnce uriPath applicationJSON)
  where
  msg = "error in query"
  uriPath = mkURI res sql

query'
  :: forall e
   . R.Resource -> SQL
  -> Aff (RetryEffects (ajax :: AJAX | e)) (Either String JS.JArray)
query' res@(R.File _) sql = do
  result <- retryGet (mkURI' res sql) applicationJSON
  pure if succeeded result.status
       then JS.decodeJson <=< JS.jsonParser $ result.response
       else Left $ readError "error in query" result.response

query' _ _ = pure $ Left "Query resource is not a file"

count :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) Int
count res = do
  result <- getOnce uriPath applicationJSON
  when (not $ succeeded result.status) raiseError
  -- See SD-1331. If user requests `count` for incorrect sql-mount
  -- it returns "[" --> throwError is used to mark non-existent and
  -- incorrect resources here.
  maybe raiseError pure $
    (JS.jsonParser result.response # either (const Nothing) Just)
    >>= JS.toArray
    >>= Arr.head
    >>= JS.toObject
    >>= SM.lookup "total"
    >>= JS.toNumber
    >>= Data.Int.fromNumber
  where
  raiseError :: forall a. Aff (RetryEffects (ajax :: AJAX |e)) a
  raiseError = throwError $ Exn.error "count query returned incorrect json"

  uriPath :: P.Path P.Abs P.File P.Sandboxed
  uriPath = mkURI res sql

  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

resourceExists :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX|e)) Boolean
resourceExists res = map isRight $ attempt $ count res

portView
  :: forall e
   . R.Resource
  -> R.Resource
  -> SQL
  -> SM.StrMap String
  -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
portView res dest sql varMap = do
  guard $ R.isFile dest
  let
    queryParams = maybe "" ("&" <>) $ renderQueryString varMap
    connectionUri = "sql2:///?q="
                    <> PU.encodeURIPath (templated res sql)
                    <> queryParams
  result <-
    slamjax $ defaultRequest
      { method = PUT
      , headers = [ ContentType applicationJSON ]
      , content = Just $ stringify { view: { connectionUri: connectionUri } }
      , url =
          P.printPath $
            Paths.mountUrl
              </> PU.rootify (R.resourceDir dest)
              </> P.file (R.resourceName dest)
      }
  if succeeded result.status
     then pure unit
     else throwError $ Exn.error $ readError result.response result.response

portQuery
  :: forall e
   . R.Resource
  -> R.Resource
  -> SQL
  -> SM.StrMap String
  -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JObject
portQuery res dest sql vars = do
  guard $ R.isFile dest
  result <-
    slamjax $ defaultRequest
      { method = POST
      , headers =
          [ RequestHeader "Destination" $ R.resourcePath dest
          , ContentType ldJSON
          ]
      , url =
          P.printPath $
            Paths.queryUrl
              </> PU.rootify (R.resourceDir res)
              </> P.dir (R.resourceName res)
              </> P.file queryVars
      , content = Just (templated res sql)
      }

  if not $ succeeded result.status
    then throwError $ Exn.error $ readError result.response result.response
    else
    -- We expect result message to be valid json.
    either (throwError <<< Exn.error) pure $
      JS.jsonParser result.response >>= JS.decodeJson
  where
  queryVars :: String
  queryVars = maybe "" ("?" <>) $ renderQueryString vars

renderQueryString :: SM.StrMap String -> Maybe String
renderQueryString = map go <<< L.uncons <<< SM.toList
  where
  pair :: Tuple String String -> String
  pair (Tuple a b) = "var." <> a <> "=" <> encodeURIComponent b

  go { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) (pair h) t

readError :: String -> String -> String
readError msg input =
  let responseError = JS.jsonParser input >>= JS.decodeJson >>= (.? "error")
  in either (const msg) id responseError

sample'
  :: forall e
   . R.Resource -> Maybe Int -> Maybe Int
   -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
sample' res mbOffset mbLimit =
  if not $ R.isFile res
  then pure []
  else extractJArray =<< getResponse msg (retryGet uri applicationJSON)
  where
  msg = "error getting resource sample"
  uri =
    Paths.dataUrl
      </> PU.rootify (R.resourceDir res)
      </> P.file
            (R.resourceName res
               <> (maybe "" (("?offset=" <>) <<< show) mbOffset)
               <> (maybe "" (("&limit=" <>) <<< show ) mbLimit))

sample
  :: forall e
   . R.Resource -> Int -> Int -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
sample res offset limit = sample' res (Just offset) (Just limit)

all :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
all res = sample' res Nothing Nothing

fields
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) (Array String)
fields res = do
  jarr <- sample res 0 100
  case jarr of
    [] -> throwError $ Exn.error "empty file"
    _ -> pure $ Arr.nub $ Arr.concat (getFields <$> jarr)

mkURI :: R.Resource -> SQL -> PU.FilePath
mkURI res sql =
  Paths.queryUrl </> P.file ("?q=" <> encodeURIComponent (templated res sql))

mkURI' :: R.Resource -> SQL -> PU.FilePath
mkURI' res sql =
  Paths.queryUrl
  </> PU.rootify (R.resourceDir res)
  </> P.dir (R.resourceName res)
  </> P.file ("?q=" <> encodeURIComponent (templated res sql))

templated :: R.Resource -> SQL -> SQL
templated res = S.replace "{{path}}" ("\"" <> R.resourcePath res <> "\"")

extractJArray :: forall m. (MonadError Exn.Error m) => JS.Json -> m JS.JArray
extractJArray = either (throwError <<< Exn.error) pure <<< JS.decodeJson

getFields :: JS.Json -> Array String
getFields json = Arr.filter (/= "") $ Arr.nub $ getFields' [] json

getFields' :: Array String -> JS.Json -> Array String
getFields' [] json = getFields' [""] json
getFields' acc json =
  if JS.isObject json
  then maybe acc (goObj acc) $ JS.toObject json
  else if JS.isArray json
       then maybe acc (goArr acc) $ JS.toArray json
       else acc

  where
  goArr :: Array String -> JS.JArray -> Array String
  goArr acc arr =
    Arr.concat $ getFields' (lift2 append acc $ mkArrIxs arr) <$> arr
    where
    mkArrIxs :: JS.JArray -> Array String
    mkArrIxs jarr =
      map (show >>> \x -> "[" <> x <> "]") $ Arr.range 0 $ Arr.length jarr - 1

  goObj :: Array String -> JS.JObject -> Array String
  goObj acc = Arr.concat <<< map (goTuple acc) <<< L.fromList <<< SM.toList

  goTuple :: Array String -> Tuple String JS.Json -> Array String
  goTuple acc (Tuple key json) =
    getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json

executeQuery
  :: forall e
   . String
  -> Boolean
  -> SM.StrMap String
  -> R.Resource
  -> R.Resource
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e))
      (Either String { outputResource :: R.Resource, plan :: Maybe String })
executeQuery sql cachingEnabled varMap inputResource outputResource = do
  when (R.isTempFile outputResource) $
    void $ attempt $ forceDelete outputResource

  ejobj <- do
    attempt $
      if cachingEnabled
         then portQuery inputResource outputResource sql varMap <#> Just
         else portView inputResource outputResource sql varMap $> Nothing

  pure $ do
    mjobj <- lmap Exn.message ejobj
    info <-
      case mjobj of
        Nothing -> do
          path <- R.getPath outputResource # either pure \_ ->
            Left "Expected output resource as file or view mount"
          sandboxedPath <- P.sandbox P.rootDir path
                           # maybe (Left "Could not sandbox output resource") pure
          pure
            { sandboxedPath
            , plan: Nothing
            }
        Just jobj -> do
          planPhases <- Arr.last <$> jobj .? "phases"
          sandboxedPath <- do
            pathString <- jobj .? "out"
            path <- P.parseAbsFile pathString
                    # maybe (Left "Invalid file from Quasar") pure
            P.sandbox P.rootDir path
              # maybe (Left "Could not sandbox Quasar file") pure
          pure
            { sandboxedPath
            , plan: planPhases >>= (.? "detail") >>> either (const Nothing) Just
            }
    pure
      { outputResource: R.mkFile $ Left $ P.rootDir </> info.sandboxedPath
      , plan: info.plan
      }

-- | Saves a JSON value to a file.
-- |
-- | Even though the path is expected to be absolute it should not include the
-- | `/data/fs` part of the path for the API.
save
  :: forall e
   . PU.FilePath
  -> JS.Json
  -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
save path json =
  let apiPath = Paths.dataUrl </> PU.rootifyFile path
  in getResponse "error while saving file" (retryPut apiPath json ldJSON)

-- | Loads a JSON value from a file.
-- |
-- | Even though the path is expected to be absolute it should not include the
-- | `/data/fs` part of the path for the API.
load
  :: forall e
   . PU.FilePath
  -> Aff (RetryEffects (ajax :: AJAX | e)) (Either String JS.Json)
load path =
  let apiPath = Paths.dataUrl </> PU.rootifyFile path
  in lmap Exn.message <$> attempt (getResponse "error loading notebook" (retryGet apiPath ldJSON))


Correct the CreateStore type signature

Correct the CreateStore type signature

module Redux.Mini
  ( Action
  , CreateStore
  , Dispatch
  , Middleware
  , Reducer
  , ReduxReducer
  , Store
  , STORE
  , applyMiddleware
  , applyReducer
  , combineReducers
  , connect
  , createAction
  , createReducer
  , createStore
  , provider
  , reduxCreateStore
  ) where

import Prelude
import Control.Monad.Eff (kind Effect, Eff)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn3)
import Data.Maybe (Maybe(Just))
import Data.Nullable (toMaybe, Nullable)
import React (ReactClass)

foreign import data Store :: Type
foreign import data STORE :: Effect

-- Types
-- -----

-- | An Action has a "type" for Redux compatibility, and a "pureType" to hold
-- | the actual underlying algebraic data type.
newtype Action action = Action { type :: String, pureType :: action }

-- | A function that dispatches actions
type Dispatch action eff = Action action  -- ^ The action to be dispatched
  -> Eff (store :: STORE | eff) (Action action)  -- ^ The resulting effect

-- | A simple PureScript reducer
type Reducer action state = action -> state -> state

-- | A reducer wrapped for use with Redux
newtype ReduxReducer action state =
  ReduxReducer (Fn2 (Nullable state) (Action action) state)

type CreateStore action state enhancer =
  Fn3  -- ^ An uncurried function
    (ReduxReducer action state)  -- ^ The root reducer
    state  -- ^ The initial state
    (Array enhancer)  -- ^ An array of store enhancers
    Store  -- ^ The resulting store

type Middleware eff action =
  Fn3  -- ^ An uncurried function
    Store  -- ^ The current store instance
    (Dispatch action eff)  -- ^ The dispatch function
    (Action action)  -- ^ The action currently being dispatched
    (Eff (store :: STORE | eff) (Action action))  -- ^ The resulting effect

-- Interfaces
-- ----------

-- | Easily combine reducers using the underlying Redux utility
foreign import combineReducers :: forall reducers action state.
  Record reducers -> ReduxReducer action state

-- | The <Provider/> component from react-redux
foreign import provider :: ReactClass { store :: Store }

-- | The connect wrapper from react-redux.
-- | *NOTE*: The mergeProps and options arguments are not yet supported.
foreign import connect :: forall actions state ownerProps props.
  (state -> props)  -- ^ The mapStateToProps function
  -> actions  -- ^ The mapActionsToProps object
  -> ReactClass props  -- ^ The component being wrapped
  -> ReactClass ownerProps  -- ^ The resulting higher-order component

-- | The original Redux createStore function
foreign import reduxCreateStore :: forall eff action state enhancer.
  CreateStore eff action state enhancer

foreign import applyMiddleware :: forall eff action enhancer.
  Array (Middleware eff action) -> enhancer

-- Utilities
-- ---------

createStore :: forall action state enhancer.
  ReduxReducer action state  -- ^ The root reducer
  -> state  -- ^ The initial state
  -> Array enhancer  -- ^ An array of store enhancers
  -> Store  -- ^ The resulting store
createStore = runFn3 reduxCreateStore

-- | Construct a Redux reducer, which wraps the underlying action in an Action
-- | newtype that gives it a "type" property when used in JavaScript FFI
createReducer :: forall action state.
  Reducer action state -> state -> ReduxReducer action state
createReducer reducer initialState = ReduxReducer <<< mkFn2 $
  \state (Action action) ->
    case (toMaybe state) of
      (Just s) -> applyReducer reducer action.pureType s
      otherwise -> initialState

-- | Construct a pure Redux action
createAction :: forall action. action -> Action action
createAction action = Action
  { type: typeToString action, pureType: action }

-- | Apply the given action and current state to a PureScript reducer
foreign import applyReducer :: forall action state.
  Reducer action state -> action -> state -> state

-- | Transform the action's type to a string for Redux
foreign import typeToString :: forall action. action -> String

module Redux.Mini
  ( Action
  , CreateStore
  , Dispatch
  , Middleware
  , Reducer
  , ReduxReducer
  , Store
  , STORE
  , applyMiddleware
  , applyReducer
  , combineReducers
  , connect
  , createAction
  , createReducer
  , createStore
  , provider
  , reduxCreateStore
  ) where

import Prelude
import Control.Monad.Eff (kind Effect, Eff)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn3)
import Data.Maybe (Maybe(Just))
import Data.Nullable (toMaybe, Nullable)
import React (ReactClass)

foreign import data Store :: Type
foreign import data STORE :: Effect

-- Types
-- -----

-- | An Action has a "type" for Redux compatibility, and a "pureType" to hold
-- | the actual underlying algebraic data type.
newtype Action action = Action { type :: String, pureType :: action }

-- | A function that dispatches actions
type Dispatch action eff = Action action  -- ^ The action to be dispatched
  -> Eff (store :: STORE | eff) (Action action)  -- ^ The resulting effect

-- | A simple PureScript reducer
type Reducer action state = action -> state -> state

-- | A reducer wrapped for use with Redux
newtype ReduxReducer action state =
  ReduxReducer (Fn2 (Nullable state) (Action action) state)

type CreateStore eff action state enhancer =
  Fn3  -- ^ An uncurried function
    (ReduxReducer action state)  -- ^ The root reducer
    state  -- ^ The initial state
    (Array enhancer)  -- ^ An array of store enhancers
    Store  -- ^ The resulting store

type Middleware eff action =
  Fn3  -- ^ An uncurried function
    Store  -- ^ The current store instance
    (Dispatch action eff)  -- ^ The dispatch function
    (Action action)  -- ^ The action currently being dispatched
    (Eff (store :: STORE | eff) (Action action))  -- ^ The resulting effect

-- Interfaces
-- ----------

-- | Easily combine reducers using the underlying Redux utility
foreign import combineReducers :: forall reducers action state.
  Record reducers -> ReduxReducer action state

-- | The <Provider/> component from react-redux
foreign import provider :: ReactClass { store :: Store }

-- | The connect wrapper from react-redux.
-- | *NOTE*: The mergeProps and options arguments are not yet supported.
foreign import connect :: forall actions state ownerProps props.
  (state -> props)  -- ^ The mapStateToProps function
  -> actions  -- ^ The mapActionsToProps object
  -> ReactClass props  -- ^ The component being wrapped
  -> ReactClass ownerProps  -- ^ The resulting higher-order component

-- | The original Redux createStore function
foreign import reduxCreateStore :: forall eff action state enhancer.
  CreateStore eff action state enhancer

foreign import applyMiddleware :: forall eff action enhancer.
  Array (Middleware eff action) -> enhancer

-- Utilities
-- ---------

createStore :: forall action state enhancer.
  ReduxReducer action state  -- ^ The root reducer
  -> state  -- ^ The initial state
  -> Array enhancer  -- ^ An array of store enhancers
  -> Store  -- ^ The resulting store
createStore = runFn3 reduxCreateStore

-- | Construct a Redux reducer, which wraps the underlying action in an Action
-- | newtype that gives it a "type" property when used in JavaScript FFI
createReducer :: forall action state.
  Reducer action state -> state -> ReduxReducer action state
createReducer reducer initialState = ReduxReducer <<< mkFn2 $
  \state (Action action) ->
    case (toMaybe state) of
      (Just s) -> applyReducer reducer action.pureType s
      otherwise -> initialState

-- | Construct a pure Redux action
createAction :: forall action. action -> Action action
createAction action = Action
  { type: typeToString action, pureType: action }

-- | Apply the given action and current state to a PureScript reducer
foreign import applyReducer :: forall action state.
  Reducer action state -> action -> state -> state

-- | Transform the action's type to a string for Redux
foreign import typeToString :: forall action. action -> String


Import cleanup

Import cleanup

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (zip)
import Data.Either (Either(..))
import Data.Filterable (filterMap)
import Data.Foldable (class Foldable)
import Data.Int (round)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(Just, Nothing), fromJust)
import Data.Newtype (over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (snd)
import FRP.Event (Event)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Types (Point)
import Genetics.Browser.UI.Native.GlyphBounds (clickAnnGlyphs)
import Genetics.Browser.UI.Native.View (UpdateView(..), View, browserTransform, foldView)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.Units (Bp(Bp), BpPerPixel(BpPerPixel), Chr(Chr), bpToPixels)
import Global as Global
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, translate, withContext)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

glyphifyFeatures :: Array (Feature Bp Number)
                 -> View
                 -> Array (Glyph Unit)
glyphifyFeatures fs v' = map (g v') fs
  where g v (Feature chr min max score) = do
            let y = score
                x = bpToPixels v.scale (min - v.min)
            stroke "black"
            fill "red"
            circle { x, y } 3.0

renderGlyphs :: forall f a.
                Foldable f
             => TranslateTransform
             -> Context2D
             -> f (Glyph a)
             -> Eff _ Unit
renderGlyphs tt ctx gs = withContext ctx do
  _ <- translate tt ctx
  traverse_ (renderGlyph ctx) gs

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

foreign import setViewUI :: forall eff. String -> Eff eff Unit

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

-- TODO: fetching could (should) be done completely async,
-- and done on subscribing to the Event View. Like now,
-- but less clumsy -- model rendering around the fetch function,
-- and add some caching to it

browser :: Aff _ Unit
browser = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  browserState <- makeVar

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch "./gwas.json"
      renderer :: _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: Aff _ _
      fetch = do
        fs <- f v
        let gs = glyphifyFeatures fs v
            annGs = zip fs gs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer gs

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do

    _ <- launchAff fetch

    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- thread rendering view
  -- _ <- forkAff $ forever do
    -- render when the view & features have been updated
    -- state <- peekVar browserState
    -- liftEff do

  _ <- liftEff $ unsafeCoerceEff $
       FRP.subscribe (canvasEvent "click" canvas) \p -> launchAff do
         state <- tryPeekVar browserState
         liftEff $ log $ "clicked: (" <> show p.x <> ", " <> show p.y <> ")"
         case state of
           Nothing -> liftEff $ log "no state!"
           Just s' -> do
             liftEff $ log "state!"
             let gs' :: _
                 gs' = clickAnnGlyphs s'.annotatedGlyphs p

             traverse_ (liftEff <<< log <<< showGlyph <<< snd) gs'

  -- render first frame
  fetch

main :: Eff _ _
main = launchAff browser

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, delay, forkAff, launchAff)
import Control.Monad.Aff.AVar (makeVar, peekVar, putVar, takeVar, tryPeekVar)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State.Trans (StateT(..), evalStateT, execStateT, put)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (Writer, execWriter, tell)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (zip, (..))
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Foldable (class Foldable)
import Data.Identity (Identity(..))
import Data.Int (round, toNumber)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(Just, Nothing), fromJust, isNothing)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence_, traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import FRP (FRP)
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, path, stroke)
import Genetics.Browser.GlyphF (GlyphF(..))
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Types (Point)
import Genetics.Browser.UI.Native.GlyphBounds (clickAnnGlyphs)
import Genetics.Browser.UI.Native.View (UpdateView(..), View, browserTransform, foldView)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), bpToPixels, pixelsToBp)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, translate, withContext)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

glyphifyFeatures :: Array (Feature Bp Number)
                 -> View
                 -> Array (Glyph Unit)
glyphifyFeatures fs v' = map (g v') fs
  where g v (Feature chr min max score) = do
            let y = score
                x = bpToPixels v.scale (min - v.min)
            stroke "black"
            fill "red"
            circle { x, y } 3.0

renderGlyphs :: forall f a.
                Foldable f
             => TranslateTransform
             -> Context2D
             -> f (Glyph a)
             -> Eff _ Unit
renderGlyphs tt ctx gs = withContext ctx do
  _ <- translate tt ctx
  traverse_ (renderGlyph ctx) gs

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

foreign import setViewUI :: forall eff. String -> Eff eff Unit

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

browser :: Aff _ Unit
browser = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  browserState <- makeVar

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch "./gwas.json"
      renderer :: _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: Aff _ _
      fetch = do
        fs <- f v
        let gs = glyphifyFeatures fs v
            annGs = zip fs gs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer gs

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    -- fetch
    _ <- launchAff fetch

    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- thread rendering view
  -- _ <- forkAff $ forever do
    -- render when the view & features have been updated
    -- state <- peekVar browserState
    -- liftEff do

  _ <- liftEff $ unsafeCoerceEff $
       FRP.subscribe (canvasEvent "click" canvas) \p -> launchAff do
         state <- tryPeekVar browserState
         liftEff $ log $ "clicked: (" <> show p.x <> ", " <> show p.y <> ")"
         case state of
           Nothing -> liftEff $ log "no state!"
           Just s' -> do
             liftEff $ log "state!"
             let gs' :: _
                 gs' = clickAnnGlyphs s'.annotatedGlyphs p

             traverse_ (liftEff <<< log <<< showGlyph <<< snd) gs'

  -- render first frame
  fetch

main :: Eff _ _
main = launchAff browser


clarify documentation

clarify documentation

I think you mean JSON.parse

-- | This module defines a data type and various functions for creating and
-- | manipulating JSON values. The README contains additional documentation
-- | for this module.
module Data.Argonaut.Core
  ( Json(..)
  , JNull(..)
  , JBoolean(..)
  , JNumber(..)
  , JString(..)
  , JAssoc(..)
  , JArray(..)
  , JObject(..)
  , foldJson
  , foldJsonNull
  , foldJsonBoolean
  , foldJsonNumber
  , foldJsonString
  , foldJsonArray
  , foldJsonObject
  , isNull
  , isBoolean
  , isNumber
  , isString
  , isArray
  , isObject
  , fromNull
  , fromBoolean
  , fromNumber
  , fromString
  , fromArray
  , fromObject
  , toNull
  , toBoolean
  , toNumber
  , toString
  , toArray
  , toObject
  , jsonNull
  , jsonFalse
  , jsonTrue
  , jsonZero
  , jsonEmptyArray
  , jsonSingletonArray
  , jsonEmptyObject
  , jsonSingletonObject
  , stringify
  ) where

import Prelude

import Data.Tuple (Tuple)
import Data.Maybe (Maybe(..))
import Data.Function.Uncurried (Fn5, runFn5, Fn7, runFn7)

import Data.StrMap as M

-- | A Boolean value inside some JSON data. Note that this type is exactly the
-- | same as the primitive `Boolean` type; this synonym acts only to help
-- | indicate intent.
type JBoolean = Boolean

-- | A Number value inside some JSON data. Note that this type is exactly the
-- | same as the primitive `Number` type; this synonym acts only to help
-- | indicate intent.
type JNumber = Number

-- | A String value inside some JSON data. Note that this type is exactly the
-- | same as the primitive `String` type; this synonym acts only to help
-- | indicate intent.
type JString = String

-- | A JSON array; an array containing `Json` values.
type JArray = Array Json

-- | A JSON object; a JavaScript object containing `Json` values.
type JObject = M.StrMap Json

type JAssoc = Tuple String Json

-- | The type of null values inside JSON data. There is exactly one value of
-- | this type: in JavaScript, it is written `null`. This module exports this
-- | value as `jsonNull`.
foreign import data JNull :: *

-- | The type of JSON data. The underlying representation is the same as what
-- | would be returned from JavaScript's `JSON.parse` function; that is,
-- | ordinary JavaScript booleans, strings, arrays, objects, etc.
foreign import data Json :: *

-- | Case analysis for `Json` values. See the README for more information.
foldJson
  :: forall a
   . (JNull -> a)
  -> (JBoolean -> a)
  -> (JNumber -> a)
  -> (JString -> a)
  -> (JArray -> a)
  -> (JObject -> a)
  -> Json -> a
foldJson a b c d e f json = runFn7 _foldJson a b c d e f json

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was null, and a default value for all other cases.
foldJsonNull :: forall a. a -> (JNull -> a) -> Json -> a
foldJsonNull d f j = runFn7 _foldJson f (const d) (const d) (const d) (const d) (const d) j

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was a `Boolean`, and a default value for all other cases.
foldJsonBoolean :: forall a. a -> (JBoolean -> a) -> Json -> a
foldJsonBoolean d f j = runFn7 _foldJson (const d) f (const d) (const d) (const d) (const d) j

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was a `Number`, and a default value for all other cases.
foldJsonNumber :: forall a. a -> (JNumber -> a) -> Json -> a
foldJsonNumber d f j = runFn7 _foldJson (const d) (const d) f (const d) (const d) (const d) j

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was a `String`, and a default value for all other cases.
foldJsonString :: forall a. a -> (JString -> a) -> Json -> a
foldJsonString d f j = runFn7 _foldJson (const d) (const d) (const d) f (const d) (const d) j

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was a `JArray`, and a default value for all other cases.
foldJsonArray :: forall a. a -> (JArray -> a) -> Json -> a
foldJsonArray d f j = runFn7 _foldJson (const d) (const d) (const d) (const d) f (const d) j

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was a `JObject`, and a default value for all other cases.
foldJsonObject :: forall a. a -> (JObject -> a) -> Json -> a
foldJsonObject d f j = runFn7 _foldJson (const d) (const d) (const d) (const d) (const d) f j

verbJsonType :: forall a b. b -> (a -> b) -> (b -> (a -> b) -> Json -> b) -> Json -> b
verbJsonType def f fold = fold def f

-- Tests
isJsonType :: forall a. (Boolean -> (a -> Boolean) -> Json -> Boolean) ->
              Json -> Boolean
isJsonType = verbJsonType false (const true)

isNull :: Json -> Boolean
isNull = isJsonType foldJsonNull

isBoolean :: Json -> Boolean
isBoolean = isJsonType foldJsonBoolean

isNumber :: Json -> Boolean
isNumber = isJsonType foldJsonNumber

isString :: Json -> Boolean
isString = isJsonType foldJsonString

isArray :: Json -> Boolean
isArray = isJsonType foldJsonArray

isObject :: Json -> Boolean
isObject = isJsonType foldJsonObject

-- Decoding

toJsonType
  :: forall a
   . (Maybe a -> (a -> Maybe a) -> Json -> Maybe a)
  -> Json
  -> Maybe a
toJsonType = verbJsonType Nothing Just

toNull :: Json -> Maybe JNull
toNull = toJsonType foldJsonNull

toBoolean :: Json -> Maybe JBoolean
toBoolean = toJsonType foldJsonBoolean

toNumber :: Json -> Maybe JNumber
toNumber = toJsonType foldJsonNumber

toString :: Json -> Maybe JString
toString = toJsonType foldJsonString

toArray :: Json -> Maybe JArray
toArray = toJsonType foldJsonArray

toObject :: Json -> Maybe JObject
toObject = toJsonType foldJsonObject

-- Encoding

foreign import fromNull :: JNull -> Json
foreign import fromBoolean  :: JBoolean -> Json
foreign import fromNumber :: JNumber -> Json
foreign import fromString  :: JString -> Json
foreign import fromArray :: JArray -> Json
foreign import fromObject  :: JObject -> Json

-- Defaults

foreign import jsonNull :: Json

jsonTrue :: Json
jsonTrue = fromBoolean true

jsonFalse :: Json
jsonFalse = fromBoolean false

jsonZero :: Json
jsonZero = fromNumber 0.0

jsonEmptyString :: Json
jsonEmptyString = fromString ""

jsonEmptyArray :: Json
jsonEmptyArray = fromArray []

jsonEmptyObject :: Json
jsonEmptyObject = fromObject M.empty

jsonSingletonArray :: Json -> Json
jsonSingletonArray j = fromArray [j]

jsonSingletonObject :: String -> Json -> Json
jsonSingletonObject key val = fromObject $ M.singleton key val

-- Instances

instance eqJNull :: Eq JNull where
  eq _ _ = true

instance ordJNull :: Ord JNull where
  compare _ _ = EQ

instance showJNull :: Show JNull where
  show _ = "null"

instance eqJson :: Eq Json where
  eq j1 j2 = compare j1 j2 == EQ

instance ordJson :: Ord Json where
  compare a b = runFn5 _compare EQ GT LT a b

instance showJson :: Show Json where
  show = stringify

foreign import stringify :: Json -> String

foreign import _foldJson
  :: forall z
   . Fn7
      (JNull -> z)
      (JBoolean -> z)
      (JNumber -> z)
      (JString -> z)
      (JArray -> z)
      (JObject -> z)
      Json
      z

foreign import _compare :: Fn5 Ordering Ordering Ordering Json Json Ordering

-- | This module defines a data type and various functions for creating and
-- | manipulating JSON values. The README contains additional documentation
-- | for this module.
module Data.Argonaut.Core
  ( Json(..)
  , JNull(..)
  , JBoolean(..)
  , JNumber(..)
  , JString(..)
  , JAssoc(..)
  , JArray(..)
  , JObject(..)
  , foldJson
  , foldJsonNull
  , foldJsonBoolean
  , foldJsonNumber
  , foldJsonString
  , foldJsonArray
  , foldJsonObject
  , isNull
  , isBoolean
  , isNumber
  , isString
  , isArray
  , isObject
  , fromNull
  , fromBoolean
  , fromNumber
  , fromString
  , fromArray
  , fromObject
  , toNull
  , toBoolean
  , toNumber
  , toString
  , toArray
  , toObject
  , jsonNull
  , jsonFalse
  , jsonTrue
  , jsonZero
  , jsonEmptyArray
  , jsonSingletonArray
  , jsonEmptyObject
  , jsonSingletonObject
  , stringify
  ) where

import Prelude

import Data.Tuple (Tuple)
import Data.Maybe (Maybe(..))
import Data.Function.Uncurried (Fn5, runFn5, Fn7, runFn7)

import Data.StrMap as M

-- | A Boolean value inside some JSON data. Note that this type is exactly the
-- | same as the primitive `Boolean` type; this synonym acts only to help
-- | indicate intent.
type JBoolean = Boolean

-- | A Number value inside some JSON data. Note that this type is exactly the
-- | same as the primitive `Number` type; this synonym acts only to help
-- | indicate intent.
type JNumber = Number

-- | A String value inside some JSON data. Note that this type is exactly the
-- | same as the primitive `String` type; this synonym acts only to help
-- | indicate intent.
type JString = String

-- | A JSON array; an array containing `Json` values.
type JArray = Array Json

-- | A JSON object; a JavaScript object containing `Json` values.
type JObject = M.StrMap Json

type JAssoc = Tuple String Json

-- | The type of null values inside JSON data. There is exactly one value of
-- | this type: in JavaScript, it is written `null`. This module exports this
-- | value as `jsonNull`.
foreign import data JNull :: *

-- | The type of JSON data. The underlying representation is the same as what
-- | would be returned from JavaScript's `JSON.stringify` function; that is,
-- | ordinary JavaScript booleans, strings, arrays, objects, etc.
foreign import data Json :: *

-- | Case analysis for `Json` values. See the README for more information.
foldJson
  :: forall a
   . (JNull -> a)
  -> (JBoolean -> a)
  -> (JNumber -> a)
  -> (JString -> a)
  -> (JArray -> a)
  -> (JObject -> a)
  -> Json -> a
foldJson a b c d e f json = runFn7 _foldJson a b c d e f json

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was null, and a default value for all other cases.
foldJsonNull :: forall a. a -> (JNull -> a) -> Json -> a
foldJsonNull d f j = runFn7 _foldJson f (const d) (const d) (const d) (const d) (const d) j

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was a `Boolean`, and a default value for all other cases.
foldJsonBoolean :: forall a. a -> (JBoolean -> a) -> Json -> a
foldJsonBoolean d f j = runFn7 _foldJson (const d) f (const d) (const d) (const d) (const d) j

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was a `Number`, and a default value for all other cases.
foldJsonNumber :: forall a. a -> (JNumber -> a) -> Json -> a
foldJsonNumber d f j = runFn7 _foldJson (const d) (const d) f (const d) (const d) (const d) j

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was a `String`, and a default value for all other cases.
foldJsonString :: forall a. a -> (JString -> a) -> Json -> a
foldJsonString d f j = runFn7 _foldJson (const d) (const d) (const d) f (const d) (const d) j

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was a `JArray`, and a default value for all other cases.
foldJsonArray :: forall a. a -> (JArray -> a) -> Json -> a
foldJsonArray d f j = runFn7 _foldJson (const d) (const d) (const d) (const d) f (const d) j

-- | A simpler version of `foldJson` which accepts a callback for when the
-- | `Json` argument was a `JObject`, and a default value for all other cases.
foldJsonObject :: forall a. a -> (JObject -> a) -> Json -> a
foldJsonObject d f j = runFn7 _foldJson (const d) (const d) (const d) (const d) (const d) f j

verbJsonType :: forall a b. b -> (a -> b) -> (b -> (a -> b) -> Json -> b) -> Json -> b
verbJsonType def f fold = fold def f

-- Tests
isJsonType :: forall a. (Boolean -> (a -> Boolean) -> Json -> Boolean) ->
              Json -> Boolean
isJsonType = verbJsonType false (const true)

isNull :: Json -> Boolean
isNull = isJsonType foldJsonNull

isBoolean :: Json -> Boolean
isBoolean = isJsonType foldJsonBoolean

isNumber :: Json -> Boolean
isNumber = isJsonType foldJsonNumber

isString :: Json -> Boolean
isString = isJsonType foldJsonString

isArray :: Json -> Boolean
isArray = isJsonType foldJsonArray

isObject :: Json -> Boolean
isObject = isJsonType foldJsonObject

-- Decoding

toJsonType
  :: forall a
   . (Maybe a -> (a -> Maybe a) -> Json -> Maybe a)
  -> Json
  -> Maybe a
toJsonType = verbJsonType Nothing Just

toNull :: Json -> Maybe JNull
toNull = toJsonType foldJsonNull

toBoolean :: Json -> Maybe JBoolean
toBoolean = toJsonType foldJsonBoolean

toNumber :: Json -> Maybe JNumber
toNumber = toJsonType foldJsonNumber

toString :: Json -> Maybe JString
toString = toJsonType foldJsonString

toArray :: Json -> Maybe JArray
toArray = toJsonType foldJsonArray

toObject :: Json -> Maybe JObject
toObject = toJsonType foldJsonObject

-- Encoding

foreign import fromNull :: JNull -> Json
foreign import fromBoolean  :: JBoolean -> Json
foreign import fromNumber :: JNumber -> Json
foreign import fromString  :: JString -> Json
foreign import fromArray :: JArray -> Json
foreign import fromObject  :: JObject -> Json

-- Defaults

foreign import jsonNull :: Json

jsonTrue :: Json
jsonTrue = fromBoolean true

jsonFalse :: Json
jsonFalse = fromBoolean false

jsonZero :: Json
jsonZero = fromNumber 0.0

jsonEmptyString :: Json
jsonEmptyString = fromString ""

jsonEmptyArray :: Json
jsonEmptyArray = fromArray []

jsonEmptyObject :: Json
jsonEmptyObject = fromObject M.empty

jsonSingletonArray :: Json -> Json
jsonSingletonArray j = fromArray [j]

jsonSingletonObject :: String -> Json -> Json
jsonSingletonObject key val = fromObject $ M.singleton key val

-- Instances

instance eqJNull :: Eq JNull where
  eq _ _ = true

instance ordJNull :: Ord JNull where
  compare _ _ = EQ

instance showJNull :: Show JNull where
  show _ = "null"

instance eqJson :: Eq Json where
  eq j1 j2 = compare j1 j2 == EQ

instance ordJson :: Ord Json where
  compare a b = runFn5 _compare EQ GT LT a b

instance showJson :: Show Json where
  show = stringify

foreign import stringify :: Json -> String

foreign import _foldJson
  :: forall z
   . Fn7
      (JNull -> z)
      (JBoolean -> z)
      (JNumber -> z)
      (JString -> z)
      (JArray -> z)
      (JObject -> z)
      Json
      z

foreign import _compare :: Fn5 Ordering Ordering Ordering Json Json Ordering


CSE-147 fixed String.purs import.

CSE-147 fixed String.purs import.

module Explorer.Util.String
    ( substitute
    , parseSearchEpoch
    , formatADA
    ) where

import BigNumber (BigNumberFormat(..), defaultFormat, dividedByInt, toFormat, fromString) as BN
import Control.Alt ((<|>))
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Data.Array (many)
import Data.Either (Either)
import Data.Int (fromString)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (fromCharArray)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (common, cDecimalSeparator, cGroupSeparator) as I18nL
import Explorer.Types.State (SearchEpochSlotQuery)
import Pos.Explorer.Web.ClientTypes (CCoin)
import Pos.Explorer.Web.Lenses.ClientTypes (getCoin, _CCoin)
import Text.Parsing.Parser (Parser, ParseError, runParser)
import Text.Parsing.Parser.Combinators (try)
import Text.Parsing.Parser.String (char)
import Text.Parsing.Parser.Token (digit)
import Prelude hiding (between,when)

foreign import substituteImpl :: String -> Array String -> String

-- | Substitutes `{0}` placeholders of a string
-- | * `substitute "Hello {0}, what's going on {1}" ["Jane", "today"]`
-- | * `-- output: "Hello Jane, what's going on today"`
substitute :: String -> Array String -> String
substitute = substituteImpl

-- | A simple parser for the epoch:
-- | ```purescript
-- | parseSearchEpochSlotQuery "256"
-- | ```
parseSearchEpochQuery :: Parser String SearchEpochSlotQuery
parseSearchEpochQuery = do
    epoch <- many digit >>= pure <<< fromString <<< fromCharArray
    pure $ Tuple epoch Nothing

-- | A simple parser for the epoch and slot:
-- | ```purescript
-- | parseSearchEpochSlotQuery "256,12"
-- | ```
parseSearchEpochSlotQuery :: Parser String SearchEpochSlotQuery
parseSearchEpochSlotQuery = do
    epoch <- many digit >>= pure <<< fromString <<< fromCharArray
    char ','
    slot  <- many digit >>= pure <<< fromString <<< fromCharArray
    pure $ Tuple epoch slot

-- | Combine both parsers
parseEpochOrEpochSlot :: Parser String SearchEpochSlotQuery
parseEpochOrEpochSlot = try parseSearchEpochSlotQuery <|> parseSearchEpochQuery

-- | Run the actual parser
parseSearchEpoch :: String -> Either ParseError SearchEpochSlotQuery
parseSearchEpoch input = runParser input parseEpochOrEpochSlot

formatADA :: CCoin -> Language -> String
formatADA coin lang =
    case BN.fromString $ coin ^. (_CCoin <<< getCoin) of
        Nothing -> ""
        Just bigNumber -> do
            let bigNumberADA = BN.dividedByInt bigNumber lovelacesADA
            unsafePerformEff $ BN.toFormat bigNumberADA newFormat decimalPlacesADA
    where
        decimalPlacesADA = 6
        lovelacesADA = 1000000
        newFormat = BN.BigNumberFormat $ (unwrap BN.defaultFormat)
                        { decimalSeparator = translate (I18nL.common <<< I18nL.cDecimalSeparator) lang
                        , groupSeparator = translate (I18nL.common <<< I18nL.cGroupSeparator) lang
                        }

module Explorer.Util.String
    ( substitute
    , parseSearchEpoch
    , formatADA
    ) where

import BigNumber (BigNumberFormat(..), defaultFormat, dividedByInt, toFormat, fromString) as BN
import Control.Alt ((<|>))
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Data.Array (many)
import Data.Either (Either)
import Data.Int (fromString)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (fromCharArray)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (common, cDecimalSeparator, cGroupSeparator) as I18nL
import Explorer.Types.State (SearchEpochSlotQuery)
import Pos.Explorer.Web.ClientTypes (CCoin, _CCoin)
import Pos.Explorer.Web.Lenses.ClientTypes (getCoin)
import Text.Parsing.Parser (Parser, ParseError, runParser)
import Text.Parsing.Parser.Combinators (try)
import Text.Parsing.Parser.String (char)
import Text.Parsing.Parser.Token (digit)
import Prelude hiding (between,when)

foreign import substituteImpl :: String -> Array String -> String

-- | Substitutes `{0}` placeholders of a string
-- | * `substitute "Hello {0}, what's going on {1}" ["Jane", "today"]`
-- | * `-- output: "Hello Jane, what's going on today"`
substitute :: String -> Array String -> String
substitute = substituteImpl

-- | A simple parser for the epoch:
-- | ```purescript
-- | parseSearchEpochSlotQuery "256"
-- | ```
parseSearchEpochQuery :: Parser String SearchEpochSlotQuery
parseSearchEpochQuery = do
    epoch <- many digit >>= pure <<< fromString <<< fromCharArray
    pure $ Tuple epoch Nothing

-- | A simple parser for the epoch and slot:
-- | ```purescript
-- | parseSearchEpochSlotQuery "256,12"
-- | ```
parseSearchEpochSlotQuery :: Parser String SearchEpochSlotQuery
parseSearchEpochSlotQuery = do
    epoch <- many digit >>= pure <<< fromString <<< fromCharArray
    char ','
    slot  <- many digit >>= pure <<< fromString <<< fromCharArray
    pure $ Tuple epoch slot

-- | Combine both parsers
parseEpochOrEpochSlot :: Parser String SearchEpochSlotQuery
parseEpochOrEpochSlot = try parseSearchEpochSlotQuery <|> parseSearchEpochQuery

-- | Run the actual parser
parseSearchEpoch :: String -> Either ParseError SearchEpochSlotQuery
parseSearchEpoch input = runParser input parseEpochOrEpochSlot

formatADA :: CCoin -> Language -> String
formatADA coin lang =
    case BN.fromString $ coin ^. (_CCoin <<< getCoin) of
        Nothing -> ""
        Just bigNumber -> do
            let bigNumberADA = BN.dividedByInt bigNumber lovelacesADA
            unsafePerformEff $ BN.toFormat bigNumberADA newFormat decimalPlacesADA
    where
        decimalPlacesADA = 6
        lovelacesADA = 1000000
        newFormat = BN.BigNumberFormat $ (unwrap BN.defaultFormat)
                        { decimalSeparator = translate (I18nL.common <<< I18nL.cDecimalSeparator) lang
                        , groupSeparator = translate (I18nL.common <<< I18nL.cGroupSeparator) lang
                        }