Integrate changes from #551 (SD-1168)

Integrate changes from #551 (SD-1168)

{-
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
  ( makeNotebook
  , loadNotebook
  , children
  , mountInfo
  , move
  , reqHeadersToJSON
  , saveMount
  , delete
  , getNewName
  , makeFile
  , ldJSON
  , getVersion

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

  , RetryEffects()
  ) where

import Prelude

import Config as Config
import Config.Paths as Config

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.Class (liftEff, MonadEff)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Eff.Ref (REF())
import Control.Monad.Error.Class (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)
import Data.Foldable (foldl, traverse_)
import Data.Foreign (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.Lens ((.~), (^.))
import Data.List as L
import Data.Maybe (Maybe(..), isJust, fromMaybe, maybe)
import Data.StrMap as SM
import Data.Path.Pathy as P
import Data.Path.Pathy ((</>))
import Data.String as S
import Data.Time (Milliseconds(..))
import Data.Tuple (Tuple(..))

import Model.Resource as R
import Model.Notebook as N

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 Unsafe.Coerce (unsafeCoerce)

import Utils.Path as PU
import Utils.Path ((<./>))

newtype Listing = Listing (Array R.Resource)

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

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

instance listingRespondable :: Respondable Listing where
  responseType = JSONResponse
  fromResponse = read

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

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
        }
        (Config.metadataUrl </> p)

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 <<< (Config.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 -> Affjax (RetryEffects e) a
retryGet =
  getWithPolicy
    { shouldRetryWithStatusCode: not <<< succeeded
    , delayCurve: const 1000
    , timeout: Just 30000
    }

getOnce :: forall e a fd. (Respondable a) => P.Path P.Abs fd P.Sandboxed -> Affjax (RetryEffects e) a
getOnce = getWithPolicy defaultRetryPolicy

getWithPolicy :: forall e a fd. (Respondable a) => RetryPolicy -> P.Path P.Abs fd P.Sandboxed -> Affjax (RetryEffects e) a
getWithPolicy policy u = do
  nocache <- liftEff $ Date.nowEpochMilliseconds
  retry policy affjax defaultRequest { url = url' nocache }
  where
  url' nocache = url ++ symbol ++ "nocache=" ++ pretty nocache
  url = P.printPath u
  symbol = if S.contains "?" url then "&" else "?"
  pretty (Milliseconds ms) =
    let s = show ms
    in fromMaybe s (S.stripSuffix ".0" s)

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
  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 =
    (Config.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"

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

-- Make dummy file in notebook specific folder.
-- It must be interpreted as empty notebook by notebook
-- component. Similar approach used in opening of data files, this
-- will help us decouple file and notebook subapps.
makeNotebook :: forall e. PU.DirPath -> Aff (RetryEffects (ajax :: AJAX |e)) String
makeNotebook path = do
  name <- getNewName path (Config.newNotebookName <> "." <> Config.notebookExtension)
  result <- retryPut (notebookPath name) N.emptyNotebook ldJSON
  if succeeded result.status
    then pure $ Config.notebookUrl
         <> "#" <> (PU.encodeURIPath $ P.printPath (path </> P.file name))
         <> "/edit"
    else throwError (Exn.error result.response)
  where
  notebookPath name =
    Config.dataUrl
      </> PU.rootify path
      </> P.dir name
      <./> Config.notebookExtension
      </> P.file "index"

move :: forall e. R.Resource -> PU.AnyPath -> Aff (RetryEffects (ajax :: AJAX |e)) PU.AnyPath
move src tgt = do
  let url = if R.isDatabase src || R.isViewMount src
            then Config.mountUrl
            else Config.dataUrl
  result <- slamjax $ 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 tgt
    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 $ Config.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 |e)) (Maybe R.Resource)
delete resource =
  if not (R.isDatabase resource || alreadyInTrash resource || R.isViewMount resource)
  then
    moveToTrash resource
  else do
    forceDelete resource
    pure Nothing

  where
  msg :: String
  msg = "cannot delete"

  moveToTrash :: R.Resource -> Aff (RetryEffects (ajax :: AJAX | 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 |e)) Unit
forceDelete =
  getResponse "cannot delete"
  <<< either retryDelete retryDelete
  <<< pathFromResource

  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 Config.mountUrl
    else Config.dataUrl

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

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

loadNotebook :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX |e)) N.Notebook
loadNotebook res = do
  val <-
    getResponse "error loading notebook" $ retryGet $
      Config.dataUrl
        </> PU.rootify (R.resourceDir res)
        </> P.dir (R.resourceName res)
        </> P.file "index"
  case JS.decodeJson (foreignToJson val) of
    Left err -> throwError $ Exn.error err
    Right nb -> pure nb

  where
-- TODO: Not this. either add to Argonaut, or make a Respondable Json instance
-- (requires "argonaut core" - https://github.com/slamdata/purescript-affjax/issues/16#issuecomment-93565447)
  foreignToJson :: Foreign -> JS.Json
  foreignToJson = unsafeCoerce

-- | 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 | e)))
      Unit
transitiveChildrenProducer dirPath = do
  ACR.produce \emit -> do
    runAff Exn.throwException (const (pure unit)) $ do
      let
        go start = do
          ei <- attempt $ children start
          case ei of
            Right items -> do
              liftEff $ emit (Left items)
              let parents = Arr.mapMaybe (either (const Nothing) Just <<< R.getPath) items
              traverse_ go parents
            Left _ ->
              liftEff $ emit (Right unit)
      go dirPath

-- | 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 $ retryGet uriPath)
  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)
  pure if succeeded result.status
       then Right (extractJArray 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
  fromMaybe 0 <<< readTotal <$> query res sql
  where
  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

  readTotal :: JS.JArray -> Maybe Int
  readTotal =
    Data.Int.fromNumber
      <=< JS.toNumber
      <=< SM.lookup "total"
      <=< JS.toObject
      <=< Arr.head

portView
  :: forall e
   . R.Resource
  -> R.Resource
  -> SQL
  -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
portView res dest sql = do
  guard $ R.isFile dest
  let uri = "sql2:///?q=" <> PU.encodeURIPath (templated res sql)
  result <-
    slamjax $ defaultRequest
      { method = PUT
      , headers = [ ContentType applicationJSON ]
      , content = Just $ stringify { view: { connectionUri: uri } }
      , url =
          P.printPath $
            Config.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 $
            Config.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
  -- TODO: This should be somewhere better.
  queryVars :: String
  queryVars = maybe "" makeQueryVars <<< L.uncons $ SM.toList vars

  pair :: Tuple String String -> String
  pair (Tuple a b) = "var." <> a <> "=" <> b

  makeQueryVars { 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)
  where
  msg = "error getting resource sample"
  uri =
    Config.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 = Config.queryUrl </> P.file ("?q=" <> encodeURIComponent (templated res sql))

mkURI' :: R.Resource -> SQL -> PU.FilePath
mkURI' res sql =
  Config.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 :: String -> JS.JArray
extractJArray =
  foldl folder [] <<< map JS.jsonParser <<< S.split "\n"
  where
  folder :: JS.JArray -> Either String JS.Json -> JS.JArray
  folder agg (Right j) = agg ++ [j]
  folder agg _ = agg

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.concat <<< map (getFields' $ (<> "[*]") <$> acc)

  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 | 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
    -- Pending SD-1143, the view mounts API doesn't yet support variables
    let shouldUseViews = not cachingEnabled && SM.isEmpty varMap
    attempt $
      if shouldUseViews
         then portView inputResource outputResource sql $> Nothing
         else portQuery inputResource outputResource sql varMap <#> Just

  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
      }

hole :: forall a. a
hole = Unsafe.Coerce.unsafeCoerce "hole"

{-
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
  ( makeNotebook
  , loadNotebook
  , children
  , mountInfo
  , move
  , reqHeadersToJSON
  , saveMount
  , delete
  , getNewName
  , makeFile
  , ldJSON
  , getVersion

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

  , RetryEffects()
  ) where

import Prelude

import Config as Config
import Config.Paths as Config

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.Class (liftEff, MonadEff)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Eff.Ref (REF())
import Control.Monad.Error.Class (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)
import Data.Foldable (foldl, traverse_)
import Data.Foreign (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.Lens ((.~), (^.))
import Data.List as L
import Data.Maybe (Maybe(..), isJust, fromMaybe, maybe)
import Data.StrMap as SM
import Data.Path.Pathy as P
import Data.Path.Pathy ((</>))
import Data.String as S
import Data.Time (Milliseconds(..))
import Data.Tuple (Tuple(..))

import Model.Resource as R
import Model.Notebook as N

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 Unsafe.Coerce (unsafeCoerce)

import Utils.Path as PU
import Utils.Path ((<./>))

newtype Listing = Listing (Array R.Resource)

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

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

instance listingRespondable :: Respondable Listing where
  responseType = JSONResponse
  fromResponse = read

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

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
        }
        (Config.metadataUrl </> p)

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 <<< (Config.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 -> Affjax (RetryEffects e) a
retryGet =
  getWithPolicy
    { shouldRetryWithStatusCode: not <<< succeeded
    , delayCurve: const 1000
    , timeout: Just 30000
    }

getOnce :: forall e a fd. (Respondable a) => P.Path P.Abs fd P.Sandboxed -> Affjax (RetryEffects e) a
getOnce = getWithPolicy defaultRetryPolicy

getWithPolicy :: forall e a fd. (Respondable a) => RetryPolicy -> P.Path P.Abs fd P.Sandboxed -> Affjax (RetryEffects e) a
getWithPolicy policy u = do
  nocache <- liftEff $ Date.nowEpochMilliseconds
  retry policy affjax defaultRequest { url = url' nocache }
  where
  url' nocache = url ++ symbol ++ "nocache=" ++ pretty nocache
  url = P.printPath u
  symbol = if S.contains "?" url then "&" else "?"
  pretty (Milliseconds ms) =
    let s = show ms
    in fromMaybe s (S.stripSuffix ".0" s)

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
  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 =
    (Config.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"

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

-- Make dummy file in notebook specific folder.
-- It must be interpreted as empty notebook by notebook
-- component. Similar approach used in opening of data files, this
-- will help us decouple file and notebook subapps.
makeNotebook :: forall e. PU.DirPath -> Aff (RetryEffects (ajax :: AJAX |e)) String
makeNotebook path = do
  name <- getNewName path (Config.newNotebookName <> "." <> Config.notebookExtension)
  result <- retryPut (notebookPath name) N.emptyNotebook ldJSON
  if succeeded result.status
    then pure $ Config.notebookUrl
         <> "#" <> (PU.encodeURIPath $ P.printPath (path </> P.file name))
         <> "/edit"
    else throwError (Exn.error result.response)
  where
  notebookPath name =
    Config.dataUrl
      </> PU.rootify path
      </> P.dir name
      <./> Config.notebookExtension
      </> P.file "index"

move :: forall e. R.Resource -> PU.AnyPath -> Aff (RetryEffects (ajax :: AJAX |e)) PU.AnyPath
move src tgt = do
  let url = if R.isDatabase src || R.isViewMount src
            then Config.mountUrl
            else Config.dataUrl
  result <- slamjax $ 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 tgt
    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 $ Config.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 |e)) (Maybe R.Resource)
delete resource =
  if not (R.isDatabase resource || alreadyInTrash resource || R.isViewMount resource)
  then
    moveToTrash resource
  else do
    forceDelete resource
    pure Nothing

  where
  msg :: String
  msg = "cannot delete"

  moveToTrash :: R.Resource -> Aff (RetryEffects (ajax :: AJAX | 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 |e)) Unit
forceDelete =
  getResponse "cannot delete"
  <<< either retryDelete retryDelete
  <<< pathFromResource

  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 Config.mountUrl
    else Config.dataUrl

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

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

loadNotebook :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX |e)) N.Notebook
loadNotebook res = do
  val <-
    getResponse "error loading notebook" $ retryGet $
      Config.dataUrl
        </> PU.rootify (R.resourceDir res)
        </> P.dir (R.resourceName res)
        </> P.file "index"
  case JS.decodeJson (foreignToJson val) of
    Left err -> throwError $ Exn.error err
    Right nb -> pure nb

  where
-- TODO: Not this. either add to Argonaut, or make a Respondable Json instance
-- (requires "argonaut core" - https://github.com/slamdata/purescript-affjax/issues/16#issuecomment-93565447)
  foreignToJson :: Foreign -> JS.Json
  foreignToJson = unsafeCoerce

-- | 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 | e)))
      Unit
transitiveChildrenProducer dirPath = do
  ACR.produce \emit -> do
    runAff Exn.throwException (const (pure unit)) $ do
      let
        go start = do
          ei <- attempt $ children start
          case ei of
            Right items -> do
              liftEff $ emit (Left items)
              let parents = Arr.mapMaybe (either (const Nothing) Just <<< R.getPath) items
              traverse_ go parents
            Left _ ->
              liftEff $ emit (Right unit)
      go dirPath

-- | 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 $ retryGet uriPath)
  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)
  pure if succeeded result.status
       then Right (extractJArray 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
  fromMaybe 0 <<< readTotal <$> query res sql
  where
  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

  readTotal :: JS.JArray -> Maybe Int
  readTotal =
    Data.Int.fromNumber
      <=< JS.toNumber
      <=< SM.lookup "total"
      <=< JS.toObject
      <=< Arr.head

portView
  :: forall e
   . R.Resource
  -> R.Resource
  -> SQL
  -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
portView res dest sql = do
  guard $ R.isFile dest
  let uri = "sql2:///?q=" <> PU.encodeURIPath (templated res sql)
  result <-
    slamjax $ defaultRequest
      { method = PUT
      , headers = [ ContentType applicationJSON ]
      , content = Just $ stringify { view: { connectionUri: uri } }
      , url =
          P.printPath $
            Config.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 $
            Config.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
  -- TODO: This should be somewhere better.
  queryVars :: String
  queryVars = maybe "" makeQueryVars <<< L.uncons $ SM.toList vars

  pair :: Tuple String String -> String
  pair (Tuple a b) = a <> "=" <> b

  makeQueryVars { 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)
  where
  msg = "error getting resource sample"
  uri =
    Config.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 = Config.queryUrl </> P.file ("?q=" <> encodeURIComponent (templated res sql))

mkURI' :: R.Resource -> SQL -> PU.FilePath
mkURI' res sql =
  Config.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 :: String -> JS.JArray
extractJArray =
  foldl folder [] <<< map JS.jsonParser <<< S.split "\n"
  where
  folder :: JS.JArray -> Either String JS.Json -> JS.JArray
  folder agg (Right j) = agg ++ [j]
  folder agg _ = agg

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.concat <<< map (getFields' $ (<> "[*]") <$> acc)

  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 | 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
    -- Pending SD-1143, the view mounts API doesn't yet support variables
    let shouldUseViews = not cachingEnabled && SM.isEmpty varMap
    attempt $
      if shouldUseViews
         then portView inputResource outputResource sql $> Nothing
         else portQuery inputResource outputResource sql varMap <#> Just

  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
      }

hole :: forall a. a
hole = Unsafe.Coerce.unsafeCoerce "hole"


Resolve display hacks

Resolve display hacks

module App.BoardView where

import App.FixedMatrix72 as FM
import Pux.CSS as C
import App.Board (Pit, PitRef, Player, Board, getStore)
import App.FixedMatrix72 (Row(B, A))
import Prelude (bind, const, show, ($), (<>), (<))
import Pux.CSS (Color, backgroundColor, border, display, em, px, flexFlow, fontSize, hsl, inline, left, lighten, padding, pct, rotateHue, style, width)
import Pux.Html as H
import Pux.Html (Html, div, hr, span, text)
import Pux.Html.Events (onClick)

class BoardView a where
  getBoard :: a -> Board
  isPlaying :: a -> Player -> Boolean
  pitState :: a -> PitRef -> PitState

data PitState = Normal | Lifted | Captured | Sowed

pitStateColor :: PitState -> Color
pitStateColor = go
  where go Normal = hsl 200.0 1.0 0.3
        go Captured = rotateHue 300.0 $ go Lifted
        go Lifted = rotateHue 200.0 $ go Normal
        go Sowed = lighten 0.3 $ go Normal

view :: forall action state. BoardView state
     => (PitRef -> action) -> state -> Html action
view f state =
  div []
  [ viewStore state A
  , viewRow A
  , viewRow B
  , viewStore state B
  ]
  where
    board = getBoard state
    viewRow player = div [css] $ rows
      where rows = FM.mapRowWithIndex player viewCell' board.cells
            viewCell' ref = viewCell state (f ref) ref
            css = style $ do
              apply4 C.padding (em 0.5)

viewStore :: forall a state. BoardView state
          => state -> Row -> Html a
viewStore state player = div [css] [text s]
    where s = "Player "
                <> show player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitStateColor Sowed
                  else pitStateColor Normal

viewCell :: forall a state. BoardView state
          => state -> a -> PitRef -> Pit -> Html a
viewCell state action ref count =
  H.pre [css, event] [body]
  where
    body = text $ numberPadded count
    event = onClick $ const action
    numberPadded num =
      if num < 10
        then " " <> show num
        else show num
    css = style $ do
      C.display C.inline
      C.fontSize (em 2.0)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      C.border C.solid (px 1.0) C.black
      where
        color = pitStateColor $ pitState state ref
        padding = 0.5

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a

module App.BoardView where

import App.FixedMatrix72 as FM
import App.Board (Pit, PitRef, Player, Board, getStore)
import App.FixedMatrix72 (Row(B, A))
import Prelude (bind, const, show, ($), (<>))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, rotateHue, style)
import Pux.Html (Html, div, hr, span, text)
import Pux.Html.Events (onClick)

class BoardView a where
  getBoard :: a -> Board
  isPlaying :: a -> Player -> Boolean
  pitState :: a -> PitRef -> PitState

data PitState = Normal | Lifted | Captured | Sowed

pitStateColor :: PitState -> Color
pitStateColor = go
  where go Normal = hsl 200.0 1.0 0.3
        go Captured = rotateHue 300.0 $ go Lifted
        go Lifted = rotateHue 200.0 $ go Normal
        go Sowed = lighten 0.3 $ go Normal

view :: forall action state. BoardView state
     => (PitRef -> action) -> state -> Html action
view f state =
  div []
  [ viewStore state A
  , hr [] [] -- XXX: remove this ugly display hack
  , div [] $ viewRow A
  , hr [] [] -- XXX: remove this ugly display hack
  , div [] $ viewRow B
  , hr [] [] -- XXX: remove this ugly display hack
  , viewStore state B
  ]
  where
    board = getBoard state
    viewRow player = FM.mapRowWithIndex player viewCell' board.cells
      where viewCell' ref = viewCell state (f ref) ref

viewStore :: forall a state. BoardView state
          => state -> Row -> Html a
viewStore state player =
  div [css] [text s]
    where s = "Player "
                <> show player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitStateColor Sowed
                  else pitStateColor Normal

viewCell :: forall a state. BoardView state
          => state -> a -> PitRef -> Pit -> Html a
viewCell state action ref count =
  span [css, event] [body]
  where
    body = text $ show count
    event = onClick $ const action
    css = style $ do
      backgroundColor color
      apply4 padding (em 0.9)
      where
        color = pitStateColor $ pitState state ref

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a


Use enum methods to simplify adjust

Use enum methods to simplify adjust

module Data.Date
  ( Date
  , canonicalDate
  , exactDate
  , year
  , month
  , day
  , weekday
  , diff
  , isLeapYear
  , lastDayOfMonth
  , adjust
  , module Data.Date.Component
  ) where

import Prelude

import Data.Date.Component (Day, Month(..), Weekday(..), Year)
import Data.Enum (class Enum, toEnum, fromEnum, succ, pred)
import Data.Function.Uncurried (Fn3, runFn3, Fn4, runFn4, Fn6, runFn6)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Milliseconds, toDuration)
import Partial.Unsafe (unsafePartial)

-- | A date value in the Gregorian calendar.
data Date = Date Year Month Day

-- | Constructs a date from year, month, and day components. The resulting date
-- | components may not be identical to the input values, as the date will be
-- | canonicalised according to the Gregorian calendar. For example, date
-- | values for the invalid date 2016-02-31 will be corrected to 2016-03-02.
canonicalDate :: Year -> Month -> Day -> Date
canonicalDate y m d = runFn4 canonicalDateImpl mkDate y (fromEnum m) d
  where
  mkDate :: Year -> Int -> Day -> Date
  mkDate = unsafePartial \y' m' d' -> Date y' (fromJust (toEnum m')) d'

-- | Constructs a date from year, month, and day components. The result will be
-- | `Nothing` if the provided values result in an invalid date.
exactDate :: Year -> Month -> Day -> Maybe Date
exactDate y m d =
  let dt = Date y m d
  in if canonicalDate y m d == dt then Just dt else Nothing

derive instance eqDate :: Eq Date
derive instance ordDate :: Ord Date

instance boundedDate :: Bounded Date where
  bottom = Date bottom bottom bottom
  top = Date top top top

instance showDate :: Show Date where
  show (Date y m d) = "(Date " <> show y <> " " <> show m <> " " <> show d <> ")"

instance enumDate :: Enum Date where
  succ (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing sd then toEnum 1 else sd
      m' = if isNothing sd then fromMaybe January sm else m
      y' = if isNothing sd && isNothing sm then succ y else Just y
      sd = let v = succ d in if v > Just l then Nothing else v
      sm = succ m
      l = lastDayOfMonth y m
  pred (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing pd then Just l else pd
      m' = if isNothing pd then fromMaybe December pm else m
      y' = if isNothing pd && isNothing pm then pred y else Just y
      pd = pred d
      pm = pred m
      l = lastDayOfMonth y m'

-- | The year component of a date value.
year :: Date -> Year
year (Date y _ _) = y

-- | The month component of a date value.
month :: Date -> Month
month (Date _ m _) = m

-- | The day component of a date value.
day :: Date -> Day
day (Date _ _ d) = d

-- | The weekday for a date value.
weekday :: Date -> Weekday
weekday = unsafePartial \(Date y m d) ->
  let n = runFn3 calcWeekday y (fromEnum m) d
  in if n == 0 then fromJust (toEnum 7) else fromJust (toEnum n)

-- | Adjusts a date with a Duration in days. The day duration is
-- | converted to an Int using fromNumber.
adjust :: Days -> Date -> Maybe Date
adjust (Days n) date = fromNumber n >>= flip adj date
  where
    adj 0 dt           = Just dt
    adj i (Date y m d) = adj i' =<< dt'
      where
        i'  | low       = j
            | hi        = j - fromEnum l - 1
            | otherwise = 0
        dt' | low       = pred =<< Date y m <$> toEnum 1
            | hi        = succ (Date y m l)
            | otherwise = Date y m <$> toEnum j
        j   = i + fromEnum d
        low = j < 1
        hi  = j > fromEnum l
        l   = lastDayOfMonth y (if low then fromMaybe December (pred m) else m)

-- | Calculates the difference between two dates, returning the result as a
-- | duration.
diff :: forall d. Duration d => Date -> Date -> d
diff (Date y1 m1 d1) (Date y2 m2 d2) =
  toDuration $ runFn6 calcDiff y1 (fromEnum m1) d1 y2 (fromEnum m2) d2

-- | Checks whether a year is a leap year according to the proleptic Gregorian
-- | calendar.
isLeapYear :: Year -> Boolean
isLeapYear y = (mod y' 4 == 0) && ((mod y' 400 == 0) || not (mod y' 100 == 0))
  where
  y' = fromEnum y

-- | Get the final day of a month and year, accounting for leap years.
lastDayOfMonth :: Year -> Month -> Day
lastDayOfMonth y m = case m of
  January -> unsafeDay 31
  February
    | isLeapYear y -> unsafeDay 29
    | otherwise -> unsafeDay 28
  March -> unsafeDay 31
  April -> unsafeDay 30
  May -> unsafeDay 31
  June -> unsafeDay 30
  July -> unsafeDay 31
  August -> unsafeDay 31
  September -> unsafeDay 30
  October -> unsafeDay 31
  November -> unsafeDay 30
  December -> unsafeDay 31
  where
    unsafeDay = unsafePartial fromJust <<< toEnum

-- TODO: these could (and probably should) be implemented in PS
foreign import canonicalDateImpl :: Fn4 (Year -> Int -> Day -> Date) Year Int Day Date
foreign import calcWeekday :: Fn3 Year Int Day Int
foreign import calcDiff :: Fn6 Year Int Day Year Int Day Milliseconds

module Data.Date
  ( Date
  , canonicalDate
  , exactDate
  , year
  , month
  , day
  , weekday
  , diff
  , isLeapYear
  , lastDayOfMonth
  , adjust
  , module Data.Date.Component
  ) where

import Prelude

import Data.Date.Component (Day, Month(..), Weekday(..), Year)
import Data.Enum (class Enum, toEnum, fromEnum, succ, pred)
import Data.Function.Uncurried (Fn3, runFn3, Fn4, runFn4, Fn6, runFn6)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Milliseconds, toDuration)
import Partial.Unsafe (unsafePartial)

-- | A date value in the Gregorian calendar.
data Date = Date Year Month Day

-- | Constructs a date from year, month, and day components. The resulting date
-- | components may not be identical to the input values, as the date will be
-- | canonicalised according to the Gregorian calendar. For example, date
-- | values for the invalid date 2016-02-31 will be corrected to 2016-03-02.
canonicalDate :: Year -> Month -> Day -> Date
canonicalDate y m d = runFn4 canonicalDateImpl mkDate y (fromEnum m) d
  where
  mkDate :: Year -> Int -> Day -> Date
  mkDate = unsafePartial \y' m' d' -> Date y' (fromJust (toEnum m')) d'

-- | Constructs a date from year, month, and day components. The result will be
-- | `Nothing` if the provided values result in an invalid date.
exactDate :: Year -> Month -> Day -> Maybe Date
exactDate y m d =
  let dt = Date y m d
  in if canonicalDate y m d == dt then Just dt else Nothing

derive instance eqDate :: Eq Date
derive instance ordDate :: Ord Date

instance boundedDate :: Bounded Date where
  bottom = Date bottom bottom bottom
  top = Date top top top

instance showDate :: Show Date where
  show (Date y m d) = "(Date " <> show y <> " " <> show m <> " " <> show d <> ")"

instance enumDate :: Enum Date where
  succ (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing sd then toEnum 1 else sd
      m' = if isNothing sd then fromMaybe January sm else m
      y' = if isNothing sd && isNothing sm then succ y else Just y
      sd = let v = succ d in if v > Just l then Nothing else v
      sm = succ m
      l = lastDayOfMonth y m
  pred (Date y m d) = Date <$> y' <*> pure m' <*> d'
    where
      d' = if isNothing pd then Just l else pd
      m' = if isNothing pd then fromMaybe December pm else m
      y' = if isNothing pd && isNothing pm then pred y else Just y
      pd = pred d
      pm = pred m
      l = lastDayOfMonth y m'

-- | The year component of a date value.
year :: Date -> Year
year (Date y _ _) = y

-- | The month component of a date value.
month :: Date -> Month
month (Date _ m _) = m

-- | The day component of a date value.
day :: Date -> Day
day (Date _ _ d) = d

-- | The weekday for a date value.
weekday :: Date -> Weekday
weekday = unsafePartial \(Date y m d) ->
  let n = runFn3 calcWeekday y (fromEnum m) d
  in if n == 0 then fromJust (toEnum 7) else fromJust (toEnum n)

-- | Adjusts a date with a Duration in days. The day duration is
-- | converted to an Int using fromNumber.
adjust :: Days -> Date -> Maybe Date
adjust (Days n) date =
  fromNumber n >>= \i -> (if i < 0 then adjustDown else adjustUp) i date
  where
    adjustUp :: Int -> Date -> Maybe Date
    adjustUp 0 dt = Just dt
    adjustUp i (Date y m d) = adjustUp i' =<< Date <$> y' <*> pure m' <*> d'
      where
        i' = if isNothing md then j - l - 1 else 0
        d' = if isNothing md then toEnum 1 else md
        m' = if isNothing md then fromMaybe January sm else m
        y' = if isNothing md && isNothing sm then succ y else Just y
        j   = i + fromEnum d
        md = if j > l then Nothing else toEnum j
        sm = succ m
        l  = fromEnum $ lastDayOfMonth y m

    adjustDown :: Int -> Date -> Maybe Date
    adjustDown 0 dt = Just dt
    adjustDown i (Date y m d) = adjustDown i' =<< Date <$> y' <*> pure m' <*> d'
      where
        i' = if isNothing md then j else 0
        d' = if isNothing md then Just l else md
        m' = if isNothing md then fromMaybe December pm else m
        y' = if isNothing md && isNothing pm then pred y else Just y
        j   = i + fromEnum d
        md = if j < 1 then Nothing else toEnum j
        pm = pred m
        l  = lastDayOfMonth y m'

-- | Calculates the difference between two dates, returning the result as a
-- | duration.
diff :: forall d. Duration d => Date -> Date -> d
diff (Date y1 m1 d1) (Date y2 m2 d2) =
  toDuration $ runFn6 calcDiff y1 (fromEnum m1) d1 y2 (fromEnum m2) d2

-- | Checks whether a year is a leap year according to the proleptic Gregorian
-- | calendar.
isLeapYear :: Year -> Boolean
isLeapYear y = (mod y' 4 == 0) && ((mod y' 400 == 0) || not (mod y' 100 == 0))
  where
  y' = fromEnum y

-- | Get the final day of a month and year, accounting for leap years.
lastDayOfMonth :: Year -> Month -> Day
lastDayOfMonth y m = case m of
  January -> unsafeDay 31
  February
    | isLeapYear y -> unsafeDay 29
    | otherwise -> unsafeDay 28
  March -> unsafeDay 31
  April -> unsafeDay 30
  May -> unsafeDay 31
  June -> unsafeDay 30
  July -> unsafeDay 31
  August -> unsafeDay 31
  September -> unsafeDay 30
  October -> unsafeDay 31
  November -> unsafeDay 30
  December -> unsafeDay 31
  where
    unsafeDay = unsafePartial fromJust <<< toEnum

-- TODO: these could (and probably should) be implemented in PS
foreign import canonicalDateImpl :: Fn4 (Year -> Int -> Day -> Date) Year Int Day Date
foreign import calcWeekday :: Fn3 Year Int Day Int
foreign import calcDiff :: Fn6 Year Int Day Year Int Day Milliseconds


proptypes formatted and commented

proptypes formatted and commented

module Blueprint.PropTypes where

import Prelude (negate)

type UnknownStyleType = {}

type UnknownEventType = {}

type UnknownRefType = {}

type UnknownReactType = {}

type UnknownJSXElementType = {}

type UnknownFunctionType = {} -- () => void;

type Prop a = a -> a

newtype Intent = Intent Int

-- DISCUSS: do we want to use / access these values as intent.none, intent.primary or just none, primary?
intent ::
  { none :: Intent
  , primary :: Intent
  , success :: Intent
  , warning :: Intent
  , danger :: Intent
  }
intent =
  { none : Intent (-1)
  , primary : Intent 0
  , success : Intent 1
  , warning : Intent 2
  , danger : Intent 3
  }

-- TODO: Lets discard using prefix of I. I was used in TypeScript as a way to specify Interface!
-- DISCUSS: I think r here is not necessary?
type Prpos r = PropsEx ()

-- DISCUSS: Do we need this to be extensible?
type PropsEx r = { className :: String | r }

type IntentProps = IntentPropsEx ()

type IntentPropsEx r = { intent :: Intent | r }

type ActionProps = ActionPropsEx ()

type ActionPropsEx r =
  { disabled :: Boolean
  , iconName :: String
  , onClick :: UnknownEventType
  , text :: String
  , intent :: Intent
  , className :: String
  | r
  }

type LinkProps = LinkPropsEx ()

type LinkPropsEx r =
  { href :: String
  , target :: String
  | r
  }

data ComponentORString
  = String
  | UnknownJSXElementType

type TetherConstraint =
  { attachment :: String
  , outOfBoundsClass :: String
  , pin :: ComponentORString -- Boolean | Array String
  , pinnedClass :: String
  , to :: ComponentORString --- String | UnknownReactType | Array Int
  }

module Blueprint.PropTypes where

import Prelude (negate)

type UnknownStyleType = {}

type UnknownEventType = {}

type UnknownRefType = {}

type UnknownReactType = {}

type UnknownJSXElementType = {}

type UnknownFunctionType = {} -- () => void;

type Prop a = a -> a

newtype Intent = Intent Int

intent :: { none    :: Intent
          , primary :: Intent
          , success :: Intent
          , warning :: Intent
          , danger  :: Intent
          }
intent = { none    : Intent (-1)
         , primary : Intent 0
         , success : Intent 1
         , warning : Intent 2
         , danger  : Intent 3
         }

type IPrpos r = IPropsEx ()

type IPropsEx r = { className :: String | r }

type IIntentProps = IIntentPropsEx ()

type IIntentPropsEx r = { intent :: Intent | r }

type IActionProps = IActionPropsEx ()
type IActionPropsEx r = { disabled :: Boolean
                        , iconName :: String
                        , onClick :: UnknownEventType
                        , text :: String
                        , intent :: Intent
                        , className :: String
                        | r
                        }

type ILinkProps = ILinkPropsEx ()

type ILinkPropsEx r = { href :: String
                      , target :: String
                      | r
                      }

data ComponentORString = String | UnknownJSXElementType

type ITetherConstraint = { attachment :: String
                         , outOfBoundsClass :: String
                         , pin :: ComponentORString -- Boolean | Array String
                         , pinnedClass :: String
                         , to :: ComponentORString --- String | UnknownReactType | Array Int
                         }


Move native browser to Aff

Move native browser to Aff

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import DOM.HTML.Types (HTMLElement)
import Data.Array ((..))
import Data.Filterable (filter, filterMap)
import Data.Int (toNumber)
import Data.Maybe (Maybe(Just, Nothing), fromJust, isNothing)
import Data.Newtype (unwrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..))
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, path, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), pixelsToBp)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getContext2D, setCanvasWidth)
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Point = { x :: Number
             , y :: Number }

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

genF :: String -> Bp -> Bp -> Aff _ (Feature Bp Number)
genF chr' min max = liftEff do
  let chr = Chr chr'
  score <- randomRange 5.0 10.0
  pure $ Feature chr min max score

randomFetch :: Int -> Chr -> Number -> Number -> Fetch _
randomFetch n chr min max = do
  let d = (max - min) / toNumber n
      bins = toNumber <$> 0 .. n
      rs = map (\x -> Tuple (x*d) (x*d+d)) bins

  traverse (\ (Tuple a b) -> genF "chr11" (Bp a) (Bp b)) rs

glyphify :: Feature Bp Number
         -> Glyph Unit
glyphify (Feature chr (Bp min) (Bp max) score) = do
  let height = 30.0
      color  = "red"
      midX   = min + ((max - min) / 2.0)
  stroke color
  path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]

visible :: View -> Bp -> Boolean
visible v x = v.min > x && x < v.max

hToScreen :: View -> Bp -> Number
hToScreen v x = unwrap $ v.min + (offset / (v.max - v.min))
  where offset = x - v.min

glyphifyWithView :: View
                 -> Feature Bp Number
                 -> Glyph Unit
glyphifyWithView v (Feature chr min' max' score) = do
  when (not visible v min' && not visible v max') $ pure unit

  let height = 30.0
      color  = "red"
      min    = hToScreen v min'
      max    = hToScreen v max'
      midX   = min + ((max - min) / 2.0)
  stroke color
  path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchWithView :: Int -> View -> Fetch _
fetchWithView n v = randomFetch n (Chr "chr11") (unwrap v.min) (unwrap v.max)

fetchToCanvas :: (View -> Fetch _) -> View -> Context2D -> Aff _ Unit
fetchToCanvas f v ctx = do
  features <- f v
  let gs = traverse_ glyphify features
  liftEff $ renderGlyph ctx gs

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 (Nullable Point)

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

canvasDrag :: CanvasElement -> Event (Maybe Point)
canvasDrag el = toMaybe <$> canvasDragImpl el

-- Given an event of dragging a canvas ending with Nothing,
-- produces an event of the total horizontal dragged distance when mouse is let go
horDragEv :: Event (Maybe Point) -> Event Number
horDragEv ev = ptSum `sampleOn_` doneEv
  where doneEv = filter isNothing ev
        ptSum = FRP.fold (+) (filterMap (map _.x) ev) 0.0

type View = { min :: Bp
            , max :: Bp
            , scale :: BpPerPixel
            }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange Bp Bp
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

viewBehavior :: Event UpdateView
             -> View
             -> Event View
viewBehavior ev v = FRP.fold f ev v
  where f :: UpdateView -> View -> View
        f (ScrollBp x) v' = v' { min = v'.min + x
                               , max = v'.max + x }

        f (ScrollPixels x) v' = v' { min = v'.min + (pixelsToBp v'.scale x)
                                   , max = v'.max + (pixelsToBp v'.scale x) }

        f (SetRange min' max') v' = v' { min = min'
                                       , max = max' }

        f (ModScale g) v' = v' { scale = g v'.scale }

        f (SetScale s) v' = v' { scale = s }

-- 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

-- TODO: set a range to jump the view to
-- TODO: zoom in and out
-- TODO: set zoom/scale
-- TODO: set just one side of the view?

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

  {w,h} <- liftEff $ getScreenSize
  _ <- liftEff $ setCanvasWidth (w-2.0) canvas
  backCanvas <- liftEff $ newCanvas {w,h}

  let minView = Bp 0.0
      maxView = Bp w
      v :: View
      v = { min: minView, max: maxView, scale: BpPerPixel 1.0 }
      f :: View -> Fetch _
      f = fetchWithView 100

  let cDrag = canvasDrag canvas
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls
      updateViews = btnScroll (Bp 500.0) <|>
                    (map ScrollPixels <<< horDragEv) cDrag
      viewB = viewBehavior updateViews v

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

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    clearCanvas canvas
    launchAff $ fetchToCanvas f v' ctx

  -- render first frame
  fetchToCanvas f v ctx

main = launchAff browser

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (randomRange)
import DOM.HTML.Types (HTMLElement)
import Data.Array ((..))
import Data.Filterable (filter, filterMap)
import Data.Int (toNumber)
import Data.Maybe (Maybe(Just, Nothing), fromJust, isNothing)
import Data.Newtype (unwrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..))
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, path, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), pixelsToBp)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getContext2D, setCanvasWidth)
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Point = { x :: Number
             , y :: Number }

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

genF :: String -> Bp -> Bp -> Eff _ (Feature Bp Number)
genF chr' min max = do
  let chr = Chr chr'
  score <- randomRange 5.0 10.0
  pure $ Feature chr min max score

randomFetch :: Int -> Chr -> Number -> Number -> Fetch _
randomFetch n chr min max = do
  let d = (max - min) / toNumber n
      bins = toNumber <$> 0 .. n
      rs = map (\x -> Tuple (x*d) (x*d+d)) bins

  traverse (\ (Tuple a b) -> genF "chr11" (Bp a) (Bp b)) rs

glyphify :: Feature Bp Number
         -> Glyph Unit
glyphify (Feature chr (Bp min) (Bp max) score) = do
  let height = 30.0
      color  = "red"
      midX   = min + ((max - min) / 2.0)
  stroke color
  path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]

visible :: View -> Bp -> Boolean
visible v x = v.min > x && x < v.max

hToScreen :: View -> Bp -> Number
hToScreen v x = unwrap $ v.min + (offset / (v.max - v.min))
  where offset = x - v.min

glyphifyWithView :: View
                 -> Feature Bp Number
                 -> Glyph Unit
glyphifyWithView v (Feature chr min' max' score) = do
  when (not visible v min' && not visible v max') $ pure unit

  let height = 30.0
      color  = "red"
      min    = hToScreen v min'
      max    = hToScreen v max'
      midX   = min + ((max - min) / 2.0)
  stroke color
  path [{x: min, y: score}, {x:midX, y: score+height}, {x: max, y: score}]

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchWithView :: Int -> View -> Fetch _
fetchWithView n v = randomFetch n (Chr "chr11") (unwrap v.min) (unwrap v.max)

fetchToCanvas :: (View -> Fetch _) -> View -> Context2D -> Eff _ Unit
fetchToCanvas f v ctx = do
  features <- f v
  let gs = traverse_ glyphify features
  renderGlyph ctx gs

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 (Nullable Point)

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

canvasDrag :: CanvasElement -> Event (Maybe Point)
canvasDrag el = toMaybe <$> canvasDragImpl el

-- Given an event of dragging a canvas ending with Nothing,
-- produces an event of the total horizontal dragged distance when mouse is let go
horDragEv :: Event (Maybe Point) -> Event Number
horDragEv ev = ptSum `sampleOn_` doneEv
  where doneEv = filter isNothing ev
        ptSum = FRP.fold (+) (filterMap (map _.x) ev) 0.0

type View = { min :: Bp
            , max :: Bp
            , scale :: BpPerPixel
            }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange Bp Bp
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

viewBehavior :: Event UpdateView
             -> View
             -> Event View
viewBehavior ev v = FRP.fold f ev v
  where f :: UpdateView -> View -> View
        f (ScrollBp x) v' = v' { min = v'.min + x
                               , max = v'.max + x }

        f (ScrollPixels x) v' = v' { min = v'.min + (pixelsToBp v'.scale x)
                                   , max = v'.max + (pixelsToBp v'.scale x) }

        f (SetRange min' max') v' = v' { min = min'
                                       , max = max' }

        f (ModScale g) v' = v' { scale = g v'.scale }

        f (SetScale s) v' = v' { scale = s }

-- 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

-- TODO: set a range to jump the view to
-- TODO: zoom in and out
-- TODO: set zoom/scale
-- TODO: set just one side of the view?

main :: Eff _ Unit
main = do
  canvas <- unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  {w,h} <- getScreenSize
  _ <- setCanvasWidth (w-2.0) canvas
  backCanvas <- newCanvas {w,h}

  let minView = Bp 0.0
      maxView = Bp w
      v :: View
      v = { min: minView, max: maxView, scale: BpPerPixel 1.0 }
      f :: View -> Fetch _
      f = fetchWithView 100

  let cDrag = canvasDrag canvas
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls
      updateViews = btnScroll (Bp 500.0) <|>
                    (map ScrollPixels <<< horDragEv) cDrag
      viewB = viewBehavior updateViews v

  _ <- FRP.subscribe cDrag $ case _ of
    Nothing -> pure unit
    Just {x,y}  -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- FRP.subscribe viewB \v' -> do
    clearCanvas canvas
    fetchToCanvas f v' ctx

  -- render first frame
  fetchToCanvas f v ctx