module Network.TLS.Handle

import Control.Linear.LIO
import Control.Monad.Error.Either
import Control.Monad.State
import Crypto.ECDH
import Crypto.Random
import Data.List
import Data.List1
import Data.Vect
import Data.Void
import Network.TLS.Core
import Network.TLS.Magic
import Network.TLS.Parsing
import Network.TLS.Record
import Utils.Bytes
import Utils.Handle
import Utils.Misc
import Utils.Parser

public export
tls_version_to_state_type : TLSVersion -> Type
tls_version_to_state_type TLS12 = TLSState Application2
tls_version_to_state_type TLS13 = TLSState Application3
tls_version_to_state_type _ = Void

export
record TLSHandle (version : TLSVersion) t_ok t_closed where
  constructor MkTLSHandle
  1 handle : Handle t_ok t_closed (Res String $ const t_closed) (Res String $ const t_closed)
  state : tls_version_to_state_type version
  buffer : List Bits8

public export
Uninhabited (TLSHandle TLS10 t_ok t_closed) where
  uninhabited = state

public export
Uninhabited (TLSHandle TLS11 t_ok t_closed) where
  uninhabited = state

OkOrError : TLSVersion -> Type -> Type -> Type
OkOrError tls_version t_ok t_closed = Res Bool $ \ok => if ok then TLSHandle tls_version t_ok t_closed else Res String (const t_closed)

read_record : LinearIO m => (1 _ : Handle' t_ok t_closed) -> L1 m $ Res Bool $ \ok => if ok then Res (List Bits8) (const $ Handle' t_ok t_closed) else Res String (const t_closed)
read_record handle = do
  -- read header
  (True # (b_header # handle)) <- read handle 5
  | (False # (error # handle)) => pure1 (False # ("read (record header / alert) failed: " <+> error # handle))
  let (Pure [] (Right (_, TLS12, len))) =
    feed {i = List (Posed Bits8)} (map (uncurry MkPosed) $ enumerate 0 b_header) (alert <|> record_type_with_version_with_length).decode
  | Pure [] (Left x) => (close handle) >>= (\s => pure1 (False # (("ALERT: " <+> show x) # s)))
  | _ => (close handle) >>= (\s => pure1 (False # (("unable to parse header: " <+> xxd b_header) # s)))

  -- read record content
  (True # (b_body # handle)) <- read handle (cast len)
  | (False # (error # handle)) => pure1 (False # ("read (record body) failed: " <+> error # handle))
  if length b_body == cast len
    then pure1 (True # (b_header <+> b_body # handle))
    else let err = "length does not match header: " <+> xxd b_body
               <+> "\nexpected length: " <+> show len
               <+> "\nactual length: " <+> (show $ length b_body)
         in (close handle) >>= (\s => pure1 (False # (err # s)))

gen_key : MonadRandom m => (g : SupportedGroup) -> m (DPair SupportedGroup (\g => Pair (curve_group_to_scalar_type g) (curve_group_to_element_type g)))
gen_key group = do
  keypair <- generate_key_pair @{snd $ curve_group_to_type group}
  pure (group ** keypair)

tls2_handshake : LinearIO io => TLSState ServerHello2 -> (1 _ : Handle' t_ok t_closed) -> CertificateCheck IO -> L1 io (OkOrError TLS12 t_ok t_closed)
tls2_handshake state handle cert_ok = do
  (True # (b_cert # handle)) <- read_record handle
  | (False # other) => pure1 (False # other)

  let Right state = serverhello2_to_servercert state b_cert
  | Left error => (close handle) >>= (\s => pure1 (False # (error # s)))

  (True # (b_skex # handle)) <- read_record handle
  | (False # other) => pure1 (False # other)

  Right state <- liftIO1 $ servercert_to_serverkex state b_skex cert_ok
  | Left error => (close handle) >>= (\s => pure1 (False # (error # s)))

  (True # (b_s_hello_done # handle)) <- read_record handle
  | (False # other) => pure1 (False # other)

  let Right (state, handshake_data) = serverkex_process_serverhellodone state b_s_hello_done
  | Left error => (close handle) >>= (\s => pure1 (False # (error # s)))

  (True # handle) <- write handle handshake_data
  | (False # (error # handle)) => pure1 (False # ("send_byte (handshake data) failed: " <+> error # handle))

  (True # (b_ccs # handle)) <- read_record handle
  | (False # other) => pure1 (False # other)

  let Right state = serverhellodone_to_applicationready2 state b_ccs
  | Left error => (close handle) >>= (\s => pure1 (False # (error # s)))

  (True # (b_fin # handle)) <- read_record handle
  | (False # other) => pure1 (False # other)

  case applicationready2_to_application2 state b_fin of
    Right state => pure1 (True # MkTLSHandle handle state [])
    Left error => (close handle) >>= (\s => pure1 (False # (error # s)))

tls3_handshake : LinearIO io => TLSState ServerHello3 -> (1 _ : Handle' t_ok t_closed) -> CertificateCheck IO -> L1 io (OkOrError TLS13 t_ok t_closed)
tls3_handshake state handle cert_ok = do
  (True # (b_response # handle)) <- read_record handle
  | (False # other) => pure1 (False # other)
  parsed <- liftIO1 $ tls3_serverhello_to_application state b_response cert_ok
  case parsed of
    Right (Right (client_verify, state)) => do
      (True # handle) <- write handle client_verify
      | (False # (error # handle)) => pure1 (False # ("send_byte (client verify data) failed: " <+> error # handle))
      pure1 (True # MkTLSHandle handle state [])
    Right (Left state) =>
      tls3_handshake state handle cert_ok
    Left error =>
      (close handle) >>= (\s => pure1 (False # (error # s)))

DecryptFunction : Type -> Type
DecryptFunction state = state -> List Bits8 -> Either String (state, List Bits8)

EncryptFunction : Type -> Type
EncryptFunction state = state -> List Bits8 -> (state, List Bits8)

tlshandle_read : {version : _} -> LinearIO io => (wanted : Nat) -> (1 _ : TLSHandle version t_ok t_closed) -> DecryptFunction (tls_version_to_state_type version) -> L1 io (Res Bool $ ReadHack (TLSHandle version t_ok t_closed) (Res String (const t_closed)))
tlshandle_read wanted (MkTLSHandle handle state buffer) decrypt =
  let (a, b) = splitAt wanted buffer
  in if (length a) == wanted
        then pure1 (True # (a # MkTLSHandle handle state b))
        else do
          (True # (b_record # handle)) <- read_record handle
          | (False # other) => pure1 (False # other)
          case decrypt state b_record of
            Right (state, plaintext) => tlshandle_read wanted (MkTLSHandle handle state $ buffer <+> plaintext) decrypt
            Left error => (close handle) >>= (\s => pure1 (False # (error # s)))

tlshandle_write : {tls_version : TLSVersion} -> LinearIO io => List (List Bits8) -> (1 _ : TLSHandle tls_version t_ok t_closed) -> EncryptFunction (tls_version_to_state_type tls_version) -> L1 io (Res Bool $ WriteHack (TLSHandle tls_version t_ok t_closed) (Res String (const t_closed)))
tlshandle_write [] sock encrypt = pure1 (True # sock)
tlshandle_write (x :: xs) (MkTLSHandle handle state buffer) encrypt = do
  let (state, b_record) = encrypt state x
  (True # handle) <- write handle b_record
  | (False # (error # handle)) => pure1 (False # ("write (application data) failed: " <+> error # handle))
  tlshandle_write xs (MkTLSHandle handle state buffer) encrypt

||| Reference: OpenSSL
chunk_size : Nat
chunk_size = 0x2000

tlshandle_to_handle : {version : _} -> (1 _ : TLSHandle version t_ok t_closed) -> Handle' (TLSHandle version t_ok t_closed) t_closed
tlshandle_to_handle {version=TLS10} (MkTLSHandle handle state buffer) = (kill_linear state) handle
tlshandle_to_handle {version=TLS11} (MkTLSHandle handle state buffer) = (kill_linear state) handle
tlshandle_to_handle {version=TLS12} handle = MkHandle
  handle
  ( \sock, len => tlshandle_read len sock decrypt_from_record2 )
  ( \sock, input => tlshandle_write (chunk chunk_size input) sock encrypt_to_record2 )
  ( \(MkTLSHandle handle state buffer) => close handle )
tlshandle_to_handle {version=TLS13} handle = MkHandle
  handle
  ( \sock, len => tlshandle_read len sock decrypt_from_record )
  ( \sock, input => tlshandle_write (chunk chunk_size input) sock encrypt_to_record )
  ( \(MkTLSHandle handle state buffer) => close handle )

TLSHandle' : Type -> Type -> Type
TLSHandle' t_ok t_closed = Res TLSVersion $ \version => TLSHandle version t_ok t_closed

abstract_tlshandle : (1 _ : TLSHandle' t_ok t_closed) -> Handle' (TLSHandle' t_ok t_closed) t_closed
abstract_tlshandle x = MkHandle
  x
  ( \(v # h), wanted => do
      (True # (output # MkHandle h _ _ _)) <- read (tlshandle_to_handle h) wanted
      | (False # (err # x)) => pure1 $ False # (err # x)
      pure1 $ True # (output # (_ # h))
  )
  ( \(v # h), input => do
      (True # MkHandle h _ _ _) <- write (tlshandle_to_handle h) input
      | (False # (err # x)) => pure1 $ False # (err # x)
      pure1 $ True # (_ # h)
  )
  ( \(v # h) => close $ tlshandle_to_handle h
  )

export
tls_handshake : (MonadRandom IO, LinearIO io) =>
                String ->
                List1 SupportedGroup ->
                List1 SignatureAlgorithm ->
                List1 CipherSuite ->
                (1 _ : Handle' t_ok t_closed) ->
                CertificateCheck IO ->
                L1 io (Res Bool $ \ok => if ok then Handle' (TLSHandle' t_ok t_closed) t_closed else Res String (const t_closed))
tls_handshake target_hostname supported_groups signature_algos cipher_suites handle cert_ok = do
  random <- liftIO1 $ random_bytes _
  keypairs <- liftIO1 $ traverse gen_key supported_groups
  let
    (client_hello, state) =
      tls_init_to_clienthello $ TLS_Init $ MkTLSInitialState
        target_hostname
        random
        []
        cipher_suites
        signature_algos
        keypairs

  (True # handle) <- write handle client_hello
  | (False # (error # handle)) => pure1 (False # ("send client_hello failed: " <+> error # handle))

  (True # (b_server_hello # handle)) <- read_record handle
  | (False # other) => pure1 (False # other)

  case tls_clienthello_to_serverhello state b_server_hello of
    Right (Left state) => do
      (True # ok) <- tls2_handshake state handle cert_ok
      | (False # no) => pure1 (False # no)
      pure1 $ True # abstract_tlshandle (_ # ok)
    Right (Right state) => do
      (True # ok) <- tls3_handshake state handle cert_ok
      | (False # no) => pure1 (False # no)
      pure1 $ True # abstract_tlshandle (_ # ok)
    Left error => do
      h <- close handle
      pure1 $ False # (error # h)


module Common

public export
data API : Type -> Type -> Type where
  Api :  {input : Type} -> {output : Type} -> API input output

public export
Id : Type -> Type -> Type
Id s t = t


-- ------------------------------------------------------------ [ Position.idr ]
-- Module    : Lightyear.Position
-- Description : Positioning in source files.
--
-- This code is distributed under the BSD 2-clause license.
-- See the file LICENSE in the root directory for its full text.
-- --------------------------------------------------------------------- [ EOH ]
module Lightyear.Position

import Data.Nat
import Data.Strings

%default total
-- %access export

||| Generic representation of a position.
public export
record Position where
  constructor MkPos
  fname   : Maybe String
  lineNo  : Nat
  colNo   : Nat

export
defaultPos : Maybe String -> Position
defaultPos fname = MkPos fname 1 1

namespace Generic
  ||| Increment the position one character.
  export
  increment : (tabwidth  : Nat)
           -> (curr_pos  : Position)
           -> (character : Char)
           -> Position
  increment _      (MkPos f l _) '\n' = MkPos f (S l) 1
  increment twidth (MkPos f l c) '\t' = MkPos f l     (nextTab twidth)
    where
      nextTab : Nat -> Nat
      nextTab Z              = c
      nextTab twidth@(S ptw) = (divNatNZ ((minus c 1) + twidth) twidth SIsNotZ) * twidth + 1

  increment _ (MkPos f l c) _ = MkPos f l (S c)

  ||| Increment the position one character.
  export
  inc : Nat -> Position -> Char -> Position
  inc = Generic.increment

||| Increment the position one character with a default tab width of eight.
export
increment : Position -> Char -> Position
increment = Generic.increment 8

||| Increment the position one character with a default tab width of eight.
export
inc : Position -> Char -> Position
inc = Generic.increment 8

-- [ NOTE ]
--
-- When comparing ASTs it would be nice to ignore positioning information.

Eq Position where
  (==) _ _ = True

Ord Position where
  compare _ _ = EQ

export
display : Position -> String
display (MkPos (Just fname) l c) = concat [show fname, ":", show l, ":", show c]
display (MkPos Nothing      l c) = concat ["At ", show l, ":", show c]

-- --------------------------------------------------------------------- [ EOF ]


||| The Error monad (also called the Exception monad).
module Control.Monad.Error.Interface

import Control.Monad.Error.Either
import Control.Monad.Maybe
import Control.Monad.RWS.CPS
import Control.Monad.Reader.Reader
import Control.Monad.State.State
import Control.Monad.Trans
import Control.Monad.Writer.CPS

%default total

||| The strategy of combining computations that can throw exceptions
||| by bypassing bound functions
||| from the point an exception is thrown to the point that it is handled.
||| Is parameterized over the type of error information and
||| the monad type constructor.
||| It is common to use `Either String` as the monad type constructor
||| for an error monad in which error descriptions take the form of strings.
||| In that case and many other common cases the resulting monad is already defined
||| as an instance of the 'MonadError' class.
public export
interface Monad m => MonadError e m | m where
  ||| Is used within a monadic computation to begin exception processing.
  throwError : e -> m a

  ||| A handler function to handle previous errors and return to normal execution.
  ||| A common idiom is:
  |||
  ||| ```idris example
  ||| do { action1; action2; action3 } `catchError` handler
  ||| ```
  catchError : m a -> (e -> m a) -> m a

||| Lifts an `Either e` into any `MonadError e`.
public export
liftEither : MonadError e m => Either e a -> m a
liftEither = either throwError pure

||| Makes a success or failure of an action visible in
||| the return type.
public export
tryError : MonadError e m => m a -> m (Either e a)
tryError action = (map Right action) `catchError` (pure . Left)

||| `MonadError` analogue to the `withEitherT` function.
||| Modify the value (but not the type) of an error.
||| If you need to change the type of `e` use `mapError`.
public export
withError : MonadError e m => (e -> e) -> m a -> m a
withError f action = tryError action >>= either (throwError . f) pure

||| Flipped version of `catchError`.
public export
handleError : MonadError e m => (e -> m a) -> m a -> m a
handleError = flip catchError

||| `MonadError` analogue of the `mapEitherT` function.  The
||| computation is unwrapped, a function is applied to the `Either`, and
||| the result is lifted into the second `MonadError` instance.
public export
mapError : (MonadError e m, MonadError e' n)
         => (m (Either e a) -> n (Either e' b)) -> m a -> n b
mapError f action = f (tryError action) >>= liftEither

--------------------------------------------------------------------------------
--          Implementations
--------------------------------------------------------------------------------

public export
MonadError () Maybe where
  throwError ()        = Nothing
  catchError Nothing f = f ()
  catchError x       _ = x

public export
MonadError e (Either e) where
  throwError             = Left
  Left  l `catchError` h = h l
  Right r `catchError` _ = Right r

public export
Monad m => MonadError e (EitherT e m) where
  throwError = throwE
  catchError = catchE

public export
MonadError e m => MonadError e (MaybeT m) where
  throwError = lift . throwError
  catchError (MkMaybeT m) f = MkMaybeT (catchError m (runMaybeT . f))

public export
MonadError e m => MonadError e (ReaderT r m) where
  throwError = lift . throwError
  catchError (MkReaderT m) f =
    MkReaderT $ \e => catchError (m e) (runReaderT e . f)

public export
MonadError e m => MonadError e (StateT r m) where
  throwError = lift . throwError
  catchError (ST m) f =
    ST $ \s => catchError (m s) (runStateT s . f)

public export
MonadError e m => MonadError e (RWST r w s m) where
  throwError = lift . throwError
  catchError (MkRWST m) f =
    MkRWST $ \r,w,s => catchError (m r w s) (\e => unRWST (f e) r w s)

public export
MonadError e m => MonadError e (WriterT w m) where
  throwError = lift . throwError
  catchError (MkWriterT m) f =
    MkWriterT $ \w => catchError (m w) (\e => unWriterT (f e) w)


module Circuits.NetList.Check

import Decidable.Equality

import Data.Nat
import Data.String
import Data.List.Elem
import Data.List.Quantifiers
import Data.Fin

import Toolkit.Decidable.Informative

import Toolkit.Data.Location
import Toolkit.Data.Whole
import Toolkit.Data.List.DeBruijn

import Ref

import Circuits.NetList.Types
import Circuits.NetList.Terms
import Circuits.NetList.AST

%default total

data Entry : (String,Ty) -> Type where
  MkEntry : (name : String)
         -> (type : Ty)
                 -> Entry (MkPair name type)

Env : List (String,Ty) -> Type
Env = Env (String,Ty) Entry

export
data Error = Mismatch Ty Ty
           | MismatchD DType DType
           | NotBound String
           | VectorExpected
           | PortChanExpected
           | PortExpected
           | OOB Nat Nat
           | ErrI String
           | Err FileContext Error
export
Show Error where
  show (Mismatch x y)
    = "Type Mismatch:\n\n"
      <+>
      unlines [unwords ["\tExpected:",show x], unwords ["\tGiven:", show y]]

  show (MismatchD x y)
    = "Type Mismatch:\n\n"
      <+>
      unlines [unwords ["\tExpected:",show x], unwords ["\tGiven:", show y]]

  show (NotBound x)
    = unwords ["Undeclared variable:", x]

  show (VectorExpected)
    = "Vector Expected"

  show (PortChanExpected)
    = "Port or Wire Expected"

  show (PortExpected)
    = "Port Expected"

  show (ErrI msg)
    = "Internal Err: " <+> msg
  show (OOB x y)
    = unwords ["Out of Bounds:" , show x, "is not within", show y]

  show (Err x y) = unwords [show x, show y]

strip : {ctxt : List (String, Ty)}
     -> Elem (s,type) ctxt -> Elem type (map Builtin.snd ctxt)
strip Here = Here
strip (There x) = There (strip x)

public export
TyCheck : Type -> Type
TyCheck = Either Error

lift : Dec a -> Error -> TyCheck a
lift (Yes prf) _ = Right prf
lift (No contra) e = Left e

namespace Elab

  export
  getDataType : FileContext
             -> (term : (type ** Term ctxt type))
                     -> TyCheck DType
  getDataType fc (MkDPair (TyPort (d,x)) snd) = pure x
  getDataType fc (MkDPair (TyChan x) snd) = pure x
  getDataType fc (MkDPair type snd)
    = Left (Err fc PortChanExpected)

  ||| Need to make sure that the indices are in the correct direction.
  rewriteTerm : Cast flow expected
             -> Index INOUT
             -> Term ctxt (TyPort (flow,type))
             -> Term ctxt (TyPort (flow,type))
  rewriteTerm c d (Var prf) = Var prf

  rewriteTerm BI (UP UB) (Index idir what idx)
    = Index (UP UB) (rewriteTerm BI (UP UB) what) idx

  rewriteTerm BI (DOWN DB) (Index idir what idx)
    = Index (DOWN DB) (rewriteTerm BI (DOWN DB) what) idx

  rewriteTerm BO (UP UB) (Index idir what idx)
    = Index (UP UB) (rewriteTerm BI (UP UB) what) idx

  rewriteTerm BO (DOWN DB) (Index idir what idx)
    = Index (DOWN DB) (rewriteTerm BI (DOWN DB) what) idx

  rewriteTerm BI _ (Project WRITE _) impossible
  rewriteTerm BO _ (Project WRITE _) impossible
  rewriteTerm BI _ (Project READ _) impossible
  rewriteTerm BO _ (Project READ _) impossible

  rewriteTerm BI _ (Cast BI _) impossible
  rewriteTerm BO _ (Cast BI _) impossible
  rewriteTerm BI _ (Cast BO _) impossible
  rewriteTerm BO _ (Cast BO _) impossible

  ||| When casting we finally know which direction indexing should go, so lets fix that.
  shouldCast : {type : DType}
            -> (flow,expected : Direction)
            -> (term : Term ctxt (TyPort (flow,type)))
                    -> Dec ( Cast flow expected
                           , Term ctxt (TyPort (expected,type))
                           )
  shouldCast flow expected term with (Cast.cast flow expected)
    shouldCast INOUT INPUT term | (Yes BI) with (dirFromCast BI)
      shouldCast INOUT INPUT term | (Yes BI) | idir
        = Yes $ MkPair BI (Cast BI (rewriteTerm BI idir term))

    shouldCast INOUT OUTPUT term | (Yes BO) with (dirFromCast BO)
      shouldCast INOUT OUTPUT term | (Yes BO) | idir
        = Yes $ MkPair BO (Cast BO (rewriteTerm BO idir term))

    shouldCast flow expected term | (No contra)
      = No (\(prf,t) => contra prf)

  portCast : {type : DType}
        -> {flow : Direction}
        -> FileContext
        -> (expected : Direction)
        -> (term : Term ctxt (TyPort (flow,type)))
                -> TyCheck (Term ctxt (TyPort (expected,type)))

  portCast {type} {flow = flow} fc exp term with (shouldCast flow exp term)
    portCast {type} {flow = flow} fc exp term | Yes (p,e)
      = Right e
    portCast {type} {flow = flow} fc exp term | No contra with (decEq flow exp)
      portCast {type} {flow = exp} fc exp term | No contra | (Yes Refl)
        = Right term
      portCast {type} {flow = flow} fc exp term | No contra | (No f)
        = Left (Err fc (Mismatch (TyPort (exp,type)) (TyPort (flow,type))))

  export
  checkPort : (fc    : FileContext)
           -> (exdir : Direction)
           -> (expty : DType)
           -> (term  : (type ** Term ctxt type))
                    -> TyCheck (Term ctxt (TyPort (exdir,expty)))

  -- [ NOTE ]
  --
  checkPort fc exdir exty (MkDPair (TyPort (given,x)) term)
    = do Refl <- lift (decEq exty x)
                      (Err fc (MismatchD exty x))

         portCast fc exdir term

  -- [ NOTE ]
  --
  -- READ implies INPUT
  checkPort fc INPUT exty (MkDPair (TyChan x) term)
    = do Refl <- lift (decEq exty x)
                      (Err fc (MismatchD exty x))

         pure (Project READ term)

  -- [ NOTE ]
  --
  -- WRITE implies OUTPUT
  checkPort fc OUTPUT exty (MkDPair (TyChan x) term)
    = do Refl <- lift (decEq exty x)
                      (Err fc (MismatchD exty x))

         Right (Project WRITE term)

  -- [ NOTE ]
  --
  -- INOUT Chan's impossible.
  checkPort fc INOUT exty (MkDPair (TyChan x) term)
     = Left (Err fc (ErrI "INOUT CHAN not expected"))

  -- [ NOTE ]
  --
  -- Gates/TyUnit not expected
  checkPort fc exdir exty (MkDPair type term)
     = Left (Err fc (Mismatch (TyPort (exdir,exty)) type))

  export
  indexDir : {flow : Direction}
          -> (fc   : FileContext)
          -> (term : Term ctxt (TyPort (flow,BVECT (W (S n) ItIsSucc) type)))
                  -> TyCheck (Index flow)
  indexDir {flow} fc term with (flow)
    indexDir {flow = flow} fc term | INPUT
      = pure (DOWN DI)
    indexDir {flow = flow} fc term | OUTPUT
      = pure (UP UO)
    indexDir {flow = flow} fc (Var prf) | INOUT
      = pure (UP UB)
    indexDir {flow = flow} fc (Index idir what idx) | INOUT
      = pure idir
    indexDir {flow = flow} fc (Project how what) | INOUT
      = Left (Err fc (ErrI "Shouldn't happen impossible indexing a projection with inout"))
    indexDir {flow = flow} fc (Cast x what) | INOUT
      = Left (Err fc (ErrI "Shouldn't happen impossible indexing a cast with inout"))

namespace TypeCheck
  export
  typeCheck : {ctxt : List (String,Ty)}
           -> (curr : Env ctxt)
           -> (ast  : AST)
                    -> TyCheck (DPair Ty (Term (map Builtin.snd ctxt)))

  typeCheck {ctxt} curr (Var x)
    = do (ty ** prf) <- lift (isIndex (get x) ctxt)
                             (Err (span x) (NotBound (get x)))

         pure (ty ** Var (strip prf))

  typeCheck curr (Port fc flow ty n body)
    = do (TyUnit ** term) <- typeCheck (MkEntry (get n) (TyPort (flow,ty))::curr) body
           | (type ** _) => Left (Err fc (Mismatch TyUnit type))

         pure (_ ** Port flow ty term)

  typeCheck curr (Wire fc ty n body)
    = do (TyUnit ** term) <- typeCheck (MkEntry (get n) (TyChan ty)::curr) body
           | (type ** _) => Left (Err fc (Mismatch TyUnit type))

         pure (_ ** Wire ty term)

  typeCheck curr (GateDecl fc n g body)
    = do (TyGate ** gate) <- typeCheck curr g
           | (type ** _) => Left (Err fc (Mismatch TyGate type))

         (TyUnit ** term) <- typeCheck (MkEntry (get n) (TyGate)::curr) body
           | (type ** _) => Left (Err fc (Mismatch TyUnit type))

         pure (_ ** GateDecl gate term)

  typeCheck curr (Assign fc i o rest)
    =  do termI <- typeCheck curr i

          ity <- getDataType fc termI

          termO <- typeCheck curr o
          oty <- getDataType fc termO

          Refl <- lift (decEq ity oty)
                       (Err fc (MismatchD ity oty))

          i' <- checkPort fc INPUT  ity termI
          o' <- checkPort fc OUTPUT ity termO

          (TyUnit ** r') <- typeCheck curr rest
           | (type ** _) => Left (Err fc (Mismatch TyUnit type))

          pure (_ ** Assign i' o' r')

  typeCheck curr (Mux fc o c l r)
    = do termO <- typeCheck curr o
         termC <- typeCheck curr c
         termL <- typeCheck curr l
         termR <- typeCheck curr r

         o' <- checkPort fc OUTPUT LOGIC termO
         c' <- checkPort fc INPUT  LOGIC termC
         l' <- checkPort fc INPUT  LOGIC termL
         r' <- checkPort fc INPUT  LOGIC termR

         pure (_ ** Mux o' c' l' r')

  typeCheck curr (GateU fc k o i)
    = do termO <- typeCheck curr o
         termI <- typeCheck curr i

         o' <- checkPort fc OUTPUT LOGIC termO
         i' <- checkPort fc INPUT  LOGIC termI

         pure (_ ** GateU k o' i')

  typeCheck curr (GateB fc k o l r)

    = do termO <- typeCheck curr o
         termL <- typeCheck curr l
         termR <- typeCheck curr r

         o' <- checkPort fc OUTPUT LOGIC termO
         l' <- checkPort fc INPUT  LOGIC termL
         r' <- checkPort fc INPUT  LOGIC termR

         pure (_ ** GateB k o' l' r')

  typeCheck curr (Index fc idx t)

    = do (TyPort (flow,BVECT (W (S n) ItIsSucc) type) ** term) <- typeCheck curr t
           | (type ** term)
               => Left (Err fc VectorExpected)

         case natToFin idx (S n) of
           Nothing => Left (OOB idx (S n))
           Just idx' => do idir <- indexDir fc term
                           pure (_ ** Index idir term idx')

  typeCheck curr (Split fc a b i)

    = do termA <- typeCheck curr a
         termB <- typeCheck curr b
         termI <- typeCheck curr i

         a' <- checkPort fc OUTPUT LOGIC termA
         b' <- checkPort fc OUTPUT LOGIC termB
         i' <- checkPort fc INPUT  LOGIC termI

         pure (_ ** Split a' b' i')

  typeCheck curr (Collect fc o l r)
    = do (TyPort (OUTPUT,BVECT (W (S (S Z)) ItIsSucc) type) ** o') <- typeCheck curr o
           | (TyPort (flow,BVECT (W (S (S n)) ItIsSucc) type) ** term)
               => Left (Err fc (Mismatch (TyPort (OUTPUT, BVECT (W (S (S Z)) ItIsSucc) type))
                                         (TyPort (flow,   BVECT (W (S (S n)) ItIsSucc) type))
                                         ))
           | (type ** term)
               => Left (Err fc VectorExpected)

         termL <- typeCheck curr l
         termR <- typeCheck curr r

         l' <- checkPort fc INPUT  type termL
         r' <- checkPort fc INPUT  type termR

         pure (_ ** Collect o' l' r')

  typeCheck curr (Shim fc dir thing)

    = do t <- typeCheck curr thing

         dtype <- getDataType fc t

         term <- checkPort fc dir dtype t

         pure (_ ** term)

  typeCheck curr (Stop x)
    = pure (_ ** Stop)

namespace Design
  export
  typeCheck : (ast : AST) -> TyCheck (Term Nil TyUnit)
  typeCheck ast with (typeCheck Nil ast)
    typeCheck ast | (Left x) = Left x
    typeCheck ast | (Right (MkDPair TyUnit term)) = Right term
    typeCheck ast | (Right (MkDPair ty snd)) = Left (Mismatch TyUnit ty)

  export
  typeCheckIO : (ast : AST) -> IO (TyCheck (Term Nil TyUnit))
  typeCheckIO ast = pure (typeCheck ast)

-- [ EOF ]


module Circuits.Idealised.Check

import Decidable.Equality

import Data.Nat
import Data.String
import Data.List.Elem
import Data.List.Quantifiers
import Data.DPair

import Toolkit.Decidable.Informative
import Toolkit.Decidable.Equality.Views

import Toolkit.Data.Graph.EdgeBounded
import Toolkit.Data.Whole
import Toolkit.Data.Location
import Toolkit.Data.DList

import Toolkit.Data.List.AtIndex
import Toolkit.DeBruijn.Context.Item
import Toolkit.DeBruijn.Context
import Toolkit.DeBruijn.Renaming

import Circuits.Split
import Circuits.Idealised.Core
import Circuits.Idealised.Types
import Circuits.Idealised.Terms
import Circuits.Idealised.AST

%default total

public export
Context : List (Ty, Usage) -> Type
Context = Context (Ty,Usage)

namespace FreeVar

  public export
  data IsFree : (item : (Ty, Usage)) -> Type
    where
      FVar : (prf : u = FREE)
                 -> IsFree (type, u)

  Uninhabited (IsFree (ty,USED)) where
    uninhabited (FVar Refl) impossible

  isFree : (item : (Ty, Usage))
                -> DecInfo ()
                           (IsFree item)
  isFree (ty, USED)
    = No () absurd

  isFree (ty, FREE)
    = Yes (FVar Refl)

  public export
  FreeVar : {types : List (Ty, Usage)}
         -> (key   : String)
         -> (ctxt  : Context types)
                  -> Type
  FreeVar str ctxt
   = Exists (Ty,Usage)
            IsFree
            str
            ctxt

  export
  lookup : {types : List (Ty, Usage)}
        -> (str  : String)
        -> (ctxt : Context types)
                -> DecInfo (Exists.Error ())
                           (FreeVar str ctxt)
  lookup = exists isFree

use : (ctxt : Context curr)
   -> (use  : Use curr prf next)
           -> Context next
use (I k (ty,FREE) :: rest) H
  = I k (ty, USED) :: rest

use (head :: tail) (T later)
  = head :: use tail later

isUsed : (ctxt : Context types)
              -> Dec (All Used types)
isUsed []
  = Yes []

isUsed ((I name x) :: tail) with (used x)
  isUsed ((I name x) :: tail) | (Yes pH) with (isUsed tail)
    isUsed ((I name x) :: tail) | (Yes pH) | (Yes pT)
      = Yes (pH :: pT)

    isUsed ((I name x) :: tail) | (Yes pH) | (No contra)
      = No (\(a::as) => contra as)

  isUsed ((I name x) :: tail) | (No contra)
    = No (\(a::as) => contra a)

withLocThrow : FileContext -> Check.Error -> Idealised a
withLocThrow fc e = throw (TyCheck $ Err fc e)

throw : Check.Error -> Idealised a
throw = (throw . TyCheck)

public export
allEqual : FileContext
        -> (a,b,c : DType)
                 -> Idealised (AllEqual a b c)
allEqual fc a b c with (Views.allEqual a b c)
  allEqual fc c c c | (Yes AE)
    = pure AE
  allEqual fc a b c | (No AB prfWhyNot)
    = withLocThrow fc (MismatchGate a b)
  allEqual fc a b c | (No AC prfWhyNot)
    = withLocThrow fc (MismatchGate a c)

data Result : (curr : List (Ty,Usage))
           -> Type
  where
    R : {cout : _}
     -> (type : Ty)
     -> (new  : Context cout)
     -> (term : Term cin type cout)
             -> Result cin

check : {cin  : List (Ty,Usage)}
     -> (curr : Context cin)
     -> (ast  : AST)
             -> Idealised (Result cin)

check curr (Var x) with (FreeVar.lookup (get x) curr)
  check curr (Var x) | (Yes (E type item prf locC locN)) with (prf)
    check curr (Var x) | (Yes (E (type, u) item prf locC locN)) | (FVar prf1) with (prf1)
      check curr (Var x) | (Yes (E (type, FREE) item prf locC locN)) | (FVar prf1) | Refl with (use (V _ locN))
        check curr (Var x) | (Yes (E (type, FREE) item prf locC locN)) | (FVar prf1) | Refl | (MkDPair next pU) with (use curr pU)
          check curr (Var x) | (Yes (E (type, FREE) item prf locC locN)) | (FVar prf1) | Refl | (MkDPair next pU) | new
            = pure (R type new (Var (V _ locN) pU))

  check curr (Var x) | (No msg _)
    = withLocThrow (span x) (ElemFail (get x) msg)

check curr (Input fc x y name body)

  = do R TyUnit Nil body <- check (I (get name) ((TyPort (MkPair x y)),FREE) :: curr)
                                    body
           | R ty Nil _ => throw (Mismatch TyUnit ty)
           | R _  xs  _ => withLocThrow fc (LinearityError xs)

       pure (R TyUnit Nil (NewSignal x y body))

check curr (Wire fc type a b body)

  = do R TyUnit Nil term <- check (I (get a) ((TyPort (MkPair OUTPUT type)), FREE) ::
                                   I (get b) ((TyPort (MkPair INPUT  type)), FREE) :: curr)
                                  body
           | R ty Nil _ => throw (Mismatch TyUnit ty)
           | R ty xs  _ => withLocThrow fc (LinearityError xs)

       pure (R TyUnit Nil (Wire type term))

check curr (Seq x y)
  = do R TyGate ex x <- check curr x
         | R ty _ _ => throw (Mismatch TyGate ty)

       R TyUnit Nil y <- check ex y
         | R ty Nil _ => throw (Mismatch TyUnit ty)
         | R ty xs  _ => throw (LinearityError xs)

       pure (R TyUnit Nil (Seq x y))

check curr (Mux fc o c a b)
  = do R (TyPort (OUTPUT,dtypeA)) cO o <- check curr o
         | _ => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,LOGIC)) cC c <- check cO c
         | R ty _ _ => withLocThrow fc (Mismatch (TyPort (INPUT,LOGIC)) ty)

       R (TyPort (INPUT,dtypeB)) cA a <- check cC a
         | _ => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,dtypeC)) cB b <- check cA b
         | _ => withLocThrow fc (PortExpected OUTPUT)

       AE <- allEqual fc dtypeA dtypeB dtypeC

       pure (R TyGate cB (Mux o c a b))

check curr (Dup fc a b i)
  = do R (TyPort (OUTPUT,dtypeA)) cA a <- check curr a
         | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (OUTPUT,dtypeB)) cB b <- check cA b
         | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,dtypeC)) cI i <- check cB i
         | ty => withLocThrow fc (PortExpected INPUT)

       AE <- allEqual fc dtypeA dtypeB dtypeC

       pure (R TyGate cI (Dup a b i))

check curr (Not fc a b)
  = do R (TyPort (OUTPUT,LOGIC)) cA a <- check curr a
         | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,LOGIC)) cB b <- check cA b
         | ty => withLocThrow fc (PortExpected INPUT)

       pure (R TyGate cB (Not a b))

check curr (Gate fc k a b c)
  = do R (TyPort (OUTPUT,LOGIC)) cA a <- check curr a
         | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,LOGIC)) cB b <- check cA b
         | ty => withLocThrow fc (PortExpected INPUT)

       R (TyPort (INPUT,LOGIC)) cC c <- check cB c
         | ty => withLocThrow fc (PortExpected INPUT)

       pure (R TyGate cC (Gate k a b c))

check curr (IndexS fc o i)
  = do R (TyPort (OUTPUT,dtypeO)) cO termO <- check curr o
         | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,BVECT (W (S Z) ItIsSucc) dtypeI)) cI termI <- check cO i
         | R (TyPort (INPUT, BVECT s type)) _ _
             => withLocThrow fc (Mismatch (TyPort (INPUT, BVECT (W (S Z) ItIsSucc) type))
                                          (TyPort (INPUT, BVECT s type)))
         | ty => withLocThrow fc (PortExpected INPUT)

       Refl <- embed (TyCheck $ Err fc (MismatchGate dtypeO  dtypeI))
                     (decEq dtypeO dtypeI)

       pure (R TyGate cI (IndexSingleton termO termI))

check curr (IndexE fc k a b i)

  = do R (TyPort (OUTPUT,dtypeA)) cA termA <- check curr a
                  | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (OUTPUT,BVECT free dtypeB)) cB termB <- check cA b
                  | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,BVECT size dtypeC)) cI termI <- check cB i
                  | ty => withLocThrow fc (PortExpected INPUT)

       AE <- allEqual fc dtypeA dtypeB dtypeC

       let p = case k of { F => minus (toNat size) 1; L => 0}

       (s ** prf) <- embed (const $ TyCheck $ Err fc (NotEdgeCase (InvalidEdge (toNat size) (S Z) (toNat free))))
                           (EdgeCase.index size p)

       Refl <- embed (TyCheck $ Err fc (NotEdgeCase (InvalidEdge (toNat size) (S Z) (toNat free))))
                     (decEq free s)

       pure (R TyGate cI (IndexEdge p prf termA termB termI))

check curr (IndexP fc p a b c i)
  = do R (TyPort (OUTPUT,dtypeA)) cA termA <- check curr a
                  | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (OUTPUT,BVECT freeB dtypeB)) cB termB <- check cA b
                  | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (OUTPUT,BVECT freeC dtypeC)) cC termC <- check cB c
                  | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,BVECT size dtypeD)) cI termI <- check cC i
                  | ty => withLocThrow fc (PortExpected INPUT)

       Refl <- embed (TyCheck $ Err fc (MismatchGate dtypeA (BVECT freeB dtypeB)))
                     (decEq dtypeA dtypeB)

       Refl <- embed (TyCheck $ Err fc (MismatchGate (BVECT freeB dtypeB) (BVECT freeC dtypeC)))
                     (decEq dtypeB dtypeC)

       Refl <- embed (TyCheck $ Err fc (MismatchGate (BVECT freeC dtypeC) (BVECT size dtypeD)))
                     (decEq dtypeC dtypeD)

       (a ** b ** prf) <- embed (const $ TyCheck $ Err fc (NotEdgeCase (InvalidSplit p (toNat size) (toNat freeB) (toNat freeC))))
                                (Pivot.index p size)

       Refl <- embed (TyCheck $ Err fc (MismatchGate (BVECT a     dtypeB)
                                                     (BVECT freeB dtypeB)))
                     (decEq freeB a)

       Refl <- embed (TyCheck $ Err fc (MismatchGate (BVECT b     dtypeB)
                                                     (BVECT freeC dtypeB)))
                     (decEq freeC b)

       pure (R TyGate cI (IndexSplit p prf termA termB termC termI))

check curr (MergeS fc o i)

  = do R (TyPort (OUTPUT,BVECT (W (S Z) ItIsSucc) dtypeO)) cO termO <- check curr o
           | R (TyPort (INPUT, BVECT s type)) _ _
                => withLocThrow fc (Mismatch (TyPort (OUTPUT, BVECT (W (S Z) ItIsSucc) type))
                                             (TyPort (INPUT,  BVECT s                  type)))
           | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT, dtypeI)) cI termI <- check cO i
           | ty => withLocThrow fc (PortExpected INPUT)

       Refl <- embed (TyCheck $ Err fc (MismatchGate dtypeO dtypeI))
                     (decEq dtypeO dtypeI)

       pure (R TyGate cI (MergeSingleton termO termI))

check curr (MergeV fc o a b)

  = do R (TyPort (OUTPUT, dtypeO)) cO termO <- check curr o
           | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT, dtypeA)) cA termA <- check cO a
           | ty => withLocThrow fc (PortExpected INPUT)

       R (TyPort (INPUT, dtypeB)) cB termB <- check cA b
           | ty => withLocThrow fc (PortExpected INPUT)

       case Views.allEqual LOGIC dtypeA dtypeB of
         Yes AE
           => do Refl <- embed (TyCheck (Err fc (MismatchGate (BVECT (W (S (S Z)) ItIsSucc) LOGIC)
                                                              dtypeO)))
                               (decEq dtypeO (BVECT (W (S (S Z)) ItIsSucc) LOGIC))

                 pure (R TyGate cB (Merge2L2V termO termA termB))
         No msg prf
           => case dtypeO of
                LOGIC => withLocThrow fc VectorExpected
                BVECT sO tO
                  => case dtypeA of
                       LOGIC => withLocThrow fc VectorExpected
                       BVECT sA tA
                         => case dtypeB of
                              LOGIC => withLocThrow fc VectorExpected
                              BVECT sB tB
                                => do prfS <- embed (TyCheck (Err fc (VectorSizeMismatch sO sA sB)))
                                                    (isPlus sA sB sO)

                                      AE <- allEqual fc tO tA tB

                                      pure (R TyGate cB (Merge2V2V prfS termO termA termB))

check curr (Stop fc)
  = do prf <- embed (TyCheck (Err fc (LinearityError curr)))
                    (isUsed curr)

       pure (R TyUnit Nil (Stop prf))

namespace Design

  export
  check : (ast : AST)
              -> Idealised (Term Nil TyUnit Nil)
  check ast
    = do R TyUnit Nil term <- check Nil ast
           | R ty _ _ => throw (TyCheck (Mismatch TyUnit ty))
         pure term

-- [ EOF ]


module Data.Bytes.Strict.API

import public Data.Bytes.Strict.Internal
import public Data.Bytes.Prim
import        Data.Bytes.Util

import Data.Word.Word8

import Data.List -- List.drop

moduleName : String
moduleName = "Data.Bytes.Strict.API"

%hide Prelude.empty

%default total

---------------------------------------------------------------------
-- Documentation
---------------------------------------------------------------------
{-

Pretty standard (strict) ByteString kind of stuff. Some operations have `'`
(prime) versions with slightly different behavior for convenience. In
particular operations which require `NonEmpty` proof have their `'` versions
give runtime errors on bad inputs instead. And things like replicate' use Int
instead of Nat.

This is to support what I consider the Idris community spirit: be provably safe
when it can be made convenient, but don't force anyone to jump through hoops.
I'm sure there's better wording for that though.

Included are some intended complexity values. They might be a lie since I don't
understand complexity very well. Hopefully they're in the ballpark, which is
all big-o is anyway.

Open Design Questions:

Is there a reason to allow negative position values in a Bytes? If we were
using pointers there might be some cute things we could do with that but
overall it doesn't really seem useful.
If we can get Nat or Fin to compile to Int, instead of the Integer that Nat
compiles to, then Nat for both fields of Bytes makes sense.

https://hackage.haskell.org/package/bytestring-0.10.10.0/docs/src/Data.ByteString.Internal.html#concat
Should helpers take all their arguments explicitly to avoid capturing as much
in closures? Does this even happen in idris?

Should things like replicate and unfoldrN simply cast their Nat and then call
to replicate'/unfoldrN' ? If that's the case is there any advantage to
providing them, aside from reducing cast noise for users?

Should functions that return List return lazy Lists?

If you feel something is missing from the API it might not be! Internal modules
implement common interfaces, be sure to check there first. e.g. <+>
-}

-- All of this will get fancier as Idris2 gains support for documentation
-- generation.

---------------------------------------------------------------------
-- API
---------------------------------------------------------------------

-------------------------------------------------
-- Barebones basic Bytes
-------------------------------------------------

-- Intended complexity: O(1)
export
empty : Bytes
empty = neutral

-- Intended complexity: O(1)
-- Provides NonEmpty
export
singleton : Word8 -> Bytes
singleton w = unsafeCreateBytes 1 $ \p => setByte p 0 w

private
packLenBytes : Int -> List Word8 -> Bytes
packLenBytes len xs0
    = unsafeCreateBytes len $ \b => go 0 b xs0
  where
    go : Int -> MutBlock -> List Word8 -> IO ()
    go p buf [] = pure ()
    go p buf (x::xs) = setByte buf p x *> go (p+1) buf xs

-- Intended complexity: O(n)
export
pack : List Word8 -> Bytes
pack xs = packLenBytes (cast (length xs)) xs

-- Intended complexity: O(n)
export
unpack : Bytes -> List Word8
unpack (MkB fp pos len) =
  take (intToNat len) . drop (intToNat pos)
                      . unsafePerformIO . blockData $ fp

-------------------------------------------------
-- Basic interface
-------------------------------------------------

-- Intended complexity: O(1)
total
length : Bytes -> Int
length (MkB _ _ len) = len

-- Intended complexity: O(1)
export
total
null : Bytes -> Bool
null buf = 0 >= length buf

-- Intended complexity: O(1)
export
cons : Word8 -> Bytes -> Bytes
cons x (MkB p0 pos len)
    = do unsafeCreateBytes (1 + len) $ \p => do
         setByte p 0 x
         copyBlock p0 pos len p 1

-- Intended complexity: O(1)
export
snoc : Bytes -> Word8 -> Bytes
snoc (MkB p0 pos len) x
  = unsafeCreateBytes (1 + len) $ \p => do
      copyBlock p0 pos len p 0
      setByte p len x

-- Intended complexity: O(1)
export
head : (b : Bytes) -> NonEmpty b => Word8
head (MkB b pos _) = unsafePerformIO (getByte b pos)

export
partial
head' : (b : Bytes) -> Word8
head' (MkB b pos len) = if 0 >= len
  then errorCall moduleName "head'" "block empty"
  else unsafePerformIO (getByte b pos)

-- Intended complexity: O(1)
export
tail : (b : Bytes) -> NonEmpty b => Bytes
tail (MkB p pos len) = MkB p (1 + pos) (len - 1)

export
partial
tail' : Bytes -> Bytes
tail' (MkB p pos len) = if len > 0
                          then MkB p (1 + pos) (len - 1)
                          else errorCall moduleName "tail'" "block empty"

-- Intended complexity: O(1)
export
uncons : (b : Bytes) -> NonEmpty b => (Word8, Bytes)
uncons bs = (head bs, tail bs)

export
uncons' : Bytes -> Maybe (Word8, Bytes)
uncons' bs@(MkB _ _ len) = if len > 0
                             then Just ( assert_total $ head' bs
                                       , assert_total $ tail' bs)
                             else Nothing

export
partial
uncons'' : Bytes -> (Word8, Bytes)
uncons'' bs@(MkB _ _ len)
  = if len > 0
      then (head' bs, tail' bs)
      else errorCall moduleName "uncons''" "block empty"

-- Intended complexity: O(1)
export
last : (b : Bytes) -> NonEmpty b => Word8
last (MkB p pos len) = unsafePerformIO (getByte p (len + pos - 1))

export
partial
last' : Bytes -> Word8
last' (MkB p pos len) = if len > 0
                          then unsafePerformIO (getByte p (len + pos - 1))
                          else errorCall moduleName "last'" "block empty"

-- Intended complexity: O(1)
export
init : (b: Bytes) -> NonEmpty b => Bytes
init (MkB p pos len) = MkB p pos (len - 1)

export
partial
init' : Bytes -> Bytes
init' (MkB p pos len) = if len > 0
                        then MkB p pos (len - 1)
                        else errorCall moduleName "init'" "block empty"

-- Intended complexity: O(1)
export
unsnoc : (b : Bytes) -> NonEmpty b => (Bytes, Word8)
unsnoc bs = (init bs, last bs)

export
unsnoc' : Bytes -> Maybe (Bytes, Word8)
unsnoc' bs@(MkB _ _ len) = if len > 0
                             then Just ( assert_total $ init' bs
                                       , assert_total $ last' bs)
                             else Nothing

export
partial
unsnoc'' : Bytes -> (Bytes, Word8)
unsnoc'' bs@(MkB _ _ len) = if len > 0
                              then (init' bs, last' bs)
                              else errorCall moduleName "unsnoc''" "block empty"

-------------------------------------------------
-- Transforms
-------------------------------------------------

-- Intended complexity: O(n)
export
reverse : Bytes -> Bytes
reverse b@(MkB buf pos len) = unsafeCreateBytes len $ \new =>
    rev_ 0 (len - 1) new
  where
    rev_ : Int -> Int -> MutBlock -> IO ()
    rev_ p q new = if 0 > q
      then pure ()
      else do
        x <- getByte buf (pos + p)
        setByte new q x
        assert_total $ rev_ (p+1) (q-1) new

sort : Bytes -> Bytes

intersperse : Word8 -> Bytes -> Bytes

intercalate : Bytes -> List Bytes -> Bytes

transpose : List Bytes -> List Bytes

export
stringToBytes : String -> Int -> (Bytes,Int)
stringToBytes str len = unsafeCreateNBytes' len $ \b => do
    (_,r) <- fef b (unpack str) 0
    pure (r,r)
  where
    fef : MutBlock -> List Char -> Int -> IO (MutBlock, Int)
    fef bs [] pos = pure (bs,pos)
    fef bs (c :: cs) pos = if len > pos
      then setByte bs pos (cast (cast {to=Int} c)) *> fef bs cs (pos+1)
      else pure (bs, pos)

-------------------------------------------------
-- Folding
-------------------------------------------------

-- Intended complexity: O(n)
export
foldl : (a -> Word8 -> a) -> a -> Bytes -> a
foldl f v (MkB b pos len)
    = unsafePerformIO $ go v pos (len + pos)
  where
    go : a -> (start : Int) -> (end : Int) -> IO a
    go z p q
      = if p >= q then pure z
                  else assert_total $ go (f z !(getByte b p)) (p+1) q

-- TODO: consider foldl', foldl with a lazy accumulator

foldl1 : (Word8 -> Word8 -> Word8) -> (b : Bytes) -> NonEmpty b => Word8
foldl1 f b = foldl f (head b) (tail b)

partial
foldl1' : (Word8 -> Word8 -> Word8) -> (b : Bytes) -> Word8
foldl1' f b = foldl f (head' b) (tail'
 b)

-- Intended complexity: O(n)
export
foldr : (Word8 -> a -> a) -> a -> Bytes -> a
foldr f v (MkB bs pos len)
    = unsafePerformIO $ go v pos (len + pos - 1)
  where
    go : a -> (start : Int) -> (end : Int) -> IO a
    go z p q
      = if p > q then pure z
                 else assert_total $ go (f !(getByte bs q) z) p (q-1)

-- TODO: consider foldr', foldr with a lazy accumulator

foldr1 : (Word8 -> Word8 -> Word8) -> (b : Bytes) -> NonEmpty b => Word8
foldr1 f b = foldr f (last b) (init b)

partial
foldr1' : (Word8 -> Word8 -> Word8) -> Bytes -> Word8
foldr1' f b = foldr f (last' b) (init' b)

concat : List Bytes -> Bytes

concatMap : (Word8 -> Bytes) -> Bytes -> Bytes

-------------------------------------------------
-- Mapping
-------------------------------------------------

-- Intended complexity: O(n)
export
map : (Word8 -> Word8) -> Bytes -> Bytes
map f (MkB b0 pos len)
    = unsafeCreateBytes len $ \new => map_ 0 len new
  where
    map_ : (pos1 : Int) -> (pos2 : Int) -> MutBlock -> IO ()
    map_ p q buf = if p >= q then pure ()
                             else do
                               x <- getByte b0 (pos + p)
                               setByte buf p (f x)
                               assert_total $ map_ (p+1) q buf

-- foldl with a state passed along
mapAccumL : (s -> Word8 -> (s, Word8)) -> s -> Bytes -> (s, Bytes)

-- foldr with a state passed along
mapAccumR : (s -> Word8 -> (s, Word8)) -> s -> Bytes -> (s, Bytes)

-------------------------------------------------
-- Scans
-------------------------------------------------

scanl : (Word8 -> Word8 -> Word8) -> Word8 -> Bytes -> Bytes
scanl1 : (Word8 -> Word8 -> Word8) -> (b : Bytes) -> NonEmpty b => Bytes
scanl1' : (Word8 -> Word8 -> Word8) -> Bytes -> Bytes

scanr : (Word8 -> Word8 -> Word8) -> Word8 -> Bytes -> Bytes
scanr1 : (Word8 -> Word8 -> Word8) -> (b : Bytes) -> NonEmpty b => Bytes
scanr1' : (Word8 -> Word8 -> Word8) -> Bytes -> Bytes

-------------------------------------------------
-- Generate Bytes
-------------------------------------------------

-- This can be written faster with a primitive like memset, should backends be
-- inclined to provide one?
-- Like replicate for List and elsewhere negative values are treated as 0.
replicate' : Int -> Word8 -> Bytes
replicate' n w = if n > 0
                   then map (const w) $ unsafeCreateBytes n $ (\_ => pure ())
                   else neutral

-- Why does a Nat version exist you ask? To make safety painless. People are
-- hopefully going to be using Nat all over their programs for safety reasons
-- so we want to support that easily. The user littering their code with casts
-- can get tedious so we'll support that for them here. That being said,
-- replicate' exists for when you're using Int anyway and especially if that's
-- due to performance, note that Nat compiles to Integer which (depending on
-- the backend) can be slower than Int.
-- TODO: should this case on Nat or is a cast fine? What does casing gain us?
replicate : Nat -> Word8 -> Bytes
replicate n w = replicate' (cast n) w

unfoldr : (a -> Maybe (Word8, a)) -> a -> Bytes

unfoldrN : Nat -> (a -> Maybe (Word8, a)) -> a -> (Bytes, Maybe a)

unfoldrN' : Int -> (a -> Maybe (Word8, a)) -> a -> (Bytes, Maybe a)

-------------------------------------------------
-- Splitting Bytes
-------------------------------------------------

take' : Int -> Bytes -> Bytes
take  : Nat -> Bytes -> Bytes

drop' : Int -> Bytes -> Bytes
drop  : Nat -> Bytes -> Bytes

splitAt' : Int -> Bytes -> (Bytes, Bytes)
splitAt  : Nat -> Bytes -> (Bytes, Bytes)

takeWhile : (Word8 -> Bool) -> Bytes -> Bytes
dropWhile : (Word8 -> Bool) -> Bytes -> Bytes

span  : (Word8 -> Bool) -> Bytes -> (Bytes, Bytes)
spanEnd  : (Word8 -> Bool) -> Bytes -> (Bytes, Bytes) -- starts from end

-- Should I really provide break when a person can just write not?
-- Might as well, for the same reason that we provide Nat and Int versions.
break : (Word8 -> Bool) -> Bytes -> (Bytes, Bytes)
breakEnd  : (Word8 -> Bool) -> Bytes -> (Bytes, Bytes) -- starts from end

-- potentially faster than groupBy (==), depends how we write this
group : Bytes -> List Bytes

groupBy : (Word8 -> Word8 -> Bool) -> Bytes -> List Bytes

inits : Bytes -> List Bytes
tails : Bytes -> List Bytes

-- TODO: Is this really common enough a need to include?
-- returns 2nd Bytes stripped of 1st Bytes iff 1st is a prefix of 2nd
stripPrefix : Bytes -> Bytes -> Maybe Bytes

-- Same, but from the other end.
stripSuffix : Bytes -> Bytes -> Maybe Bytes

-- split on, and consume, each occurence of Word8
split : Word8 -> Bytes -> List Bytes

-- same as above with predicate to determine delimiter
splitWith : (Word8 -> Bool) -> Bytes -> List Bytes

-------------------------------------------------
-- Predicates
-------------------------------------------------

any : (Word8 -> Bool) -> Bytes -> Bool
all : (Word8 -> Bool) -> Bytes -> Bool

isPrefixOf : Bytes -> Bytes -> Bool
isSuffixOf : Bytes -> Bytes -> Bool
isInfixOf  : Bytes -> Bytes -> Bool

-------------------------------------------------
-- Searches
-------------------------------------------------

-- TODO: needs more fitting name, even though yes we have a string of bytes in
-- memory.
-- Like break but we're breaking on a Bytes instead of a Word8. Examples:
{-
breakSubstring [3,4]     [1,2,3,4,5] ~ ([1,2],[3,4,5])
breakSubstring [3]       [1,2,3,4,5] ~ ([1,2],[3,4,5])
breakSubstring [3,4,5,6] [1,2,3,4,5] ~ ([1,2,3,4,5],[]) -- NB
breakSubstring [6]       [1,2,3,4,5] ~ ([1,2,3,4,5],[])
-}
-- This is likely to be a big player when you go to write parsers for Bytes
breakSubstring : Bytes -> Bytes -> (Bytes, Bytes)

elem : Word8 -> Bytes -> Bool

-- notElem is a common enough need to provide it for users so they don't have
-- to compose `not`
notElem : Word8 -> Bytes -> Bool

maximum :  Bytes -> Word8
minimum :  Bytes -> Word8

find : (Word8 -> Bool) -> Bytes -> Maybe Word8

filter : (Word8 -> Bool) -> Bytes -> Bytes

partition : (Word8 -> Bool) -> Bytes -> (Bytes, Bytes)

-------------------------------------------------
-- Indexing
-------------------------------------------------

-- NB: Best to avoid the Nat returning options until we have a primitive cast
-- for it to Int.

index : Bytes -> Nat -> Word8

index' : Bytes -> Int -> Word8

elemIndex  : Word8 -> Bytes -> Maybe Nat
elemIndex' : Word8 -> Bytes -> Maybe Int

elemIndices  : Word8 -> Bytes -> List Nat
elemIndices' : Word8 -> Bytes -> List Int

elemIndexEnd  : Word8 -> Bytes -> Maybe Nat
elemIndexEnd' : Word8 -> Bytes -> Maybe Int

findIndex  : (Word8 -> Bool) -> Bytes -> Maybe Nat
findIndex' : (Word8 -> Bool) -> Bytes -> Maybe Int

count  : Word8 -> Bytes -> Nat
count' : Word8 -> Bytes -> Int

-------------------------------------------------
-- Zips
-------------------------------------------------

-- analogous to zip for List
zip : Bytes -> Bytes -> List (Word8, Word8)

zipWith : (Word8 -> Word8 -> a) -> Bytes -> Bytes -> List a

unzip : List (Word8, Word8) -> (Bytes, Bytes)


||| SipHash24 copied from C [reference implementation](https://github.com/veorq/SipHash/blob/master/siphash.c)
||| and rust https://doc.rust-lang.org/src/core/hash/sip.rs.html
module Data.Hashable.SipHashV2

import Data.Buffer

%default total

%inline
CROUNDS : Nat
CROUNDS = 2

%inline
DROUNDS : Nat
DROUNDS = 4

record HashState where
    constructor MkST
    v0 : Bits64
    v1 : Bits64
    v2 : Bits64
    v3 : Bits64

initHashState : HashState
initHashState = MkST
    { v0 = 0x736f6d6570736575
    , v1 = 0x646f72616e646f6d
    , v2 = 0x6c7967656e657261
    , v3 = 0x7465646279746573
    }

record PartialHash where
    constructor MkPartial
    tail : Bits64
    index : Bits64
    length : Bits64
    hst : HashState

initPartial : PartialHash
initPartial = MkPartial 0 0 0 initHashState

%inline
shl : Bits64 -> Bits64 -> Bits64
shl = prim__shl_Bits64

%inline
shr : Bits64 -> Bits64 -> Bits64
shr = prim__shr_Bits64

%inline
bor : Bits64 -> Bits64 -> Bits64
bor = prim__or_Bits64

%inline
xor : Bits64 -> Bits64 -> Bits64
xor = prim__xor_Bits64

%inline
and : Bits64 -> Bits64 -> Bits64
and = prim__and_Bits64

%inline
shr16 : Bits16 -> Bits16 -> Bits16
shr16 = prim__shr_Bits16

%inline
shr32 : Bits32 -> Bits32 -> Bits32
shr32 = prim__shr_Bits32

%inline
andInt : Int -> Int -> Int
andInt = prim__and_Int

%inline
%spec b
rotl : Bits64 -> (b : Bits64) -> Bits64
rotl x b = (x `shl` b) `bor` (x `shr` (64 - b))

-- Make the length the smallest multiple of 8 tail >= the given number
%inline
fullSize : Int -> Int
fullSize x =
    let left = x `andInt` 7
     in if (x `andInt` 7) == 0
        then x
        else x - left + 8

compress : HashState -> HashState
compress (MkST v0 v1 v2 v3) =
    let v0 = v0 + v1;
        v1 = v1 `rotl` 13;
        v1 = v1 `xor` v0;
        v0 = v0 `rotl` 32;
        v2 = v2 + v3;
        v3 = v3 `rotl` 16;
        v3 = v3 `xor` v2;
        v0 = v0 + v3;
        v3 = v3 `rotl` 21;
        v3 = v3 `xor` v0;
        v2 = v2 + v1;
        v1 = v1 `rotl` 17;
        v1 = v1 `xor` v2;
        v2 = v2 `rotl` 32;
    in MkST v0 v1 v2 v3

%inline
%spec rounds, f
repeat : (rounds : Nat) -> (f : a -> a) -> a -> a
repeat Z f x = x
repeat (S k) f x = repeat k f (f x)

%inline
hashBits64 : HashState -> Bits64 -> HashState
hashBits64 (MkST v0 v1 v2 v3) m =
    let v3 = v3 `xor` m
        MkST v0 v1 v2 v3 = repeat CROUNDS compress $ MkST v0 v1 v2 v3
        v0 = v0 `xor` m
     in MkST v0 v1 v2 v3

export
finish : PartialHash -> Bits64
finish (MkPartial tail index length hst) =
    let MkST v0 v1 v2 v3 = hst
        rest = ((length `and` 0xff) `shl` 56) `bor` tail
        v3 = v3 `xor` rest
        MkST v0 v1 v2 v3 = repeat CROUNDS compress $ MkST v0 v1 v2 v3
        v0 = v0 `xor` rest
        v2 = v2 `xor` 0xff
        MkST v0 v1 v2 v3 = repeat DROUNDS compress $ MkST v0 v1 v2 v3
     in (v0 `xor` v1) `xor` (v2 `xor` v3)

export
addBits8 : PartialHash -> Bits8 -> PartialHash
addBits8 (MkPartial tail index len hs) x = case index of
    -- finished a set of tail
    56 => MkPartial 0 0 (len + 1) $ hashBits64 hs (tail `bor` (cast x `shl` 56))
    -- add byte to partial
    _ => MkPartial (tail `bor` (cast x `shl` index)) (index + 8) (len + 1) hs

export
addBits16 : PartialHash -> Bits16 -> PartialHash
addBits16 ph x = addBits8 (addBits8 ph $ cast x) (cast $ x `shr16` 8)

export
addBits32 : PartialHash -> Bits32 -> PartialHash
addBits32 ph x = addBits16 (addBits16 ph $ cast x) (cast $ x `shr32` 16)

export
addBits64 : PartialHash -> Bits64 -> PartialHash
addBits64 (MkPartial tail index length hst) x = MkPartial tail index (length + 8) $ hashBits64 hst x

hashBuffer' : PartialHash -> Buffer -> Int -> Int -> IO PartialHash
hashBuffer' ph buf len idx = if idx >= len
    then pure ph
    else do
        word <- getBits64 buf idx
        let ph = addBits64 ph word
        hashBuffer' ph buf len (assert_smaller idx $ idx + 8)

hashBuffer : PartialHash -> Buffer -> IO PartialHash
hashBuffer ph buf = do
    rawLen <- rawSize buf
    let len = fullSize rawLen
    Just buf' <- resizeBuffer buf len
        | Nothing => hashBuffer' ph buf (rawLen `andInt` (- 7)) 0
    hashBuffer' ph buf' len 0


module VNode

import Attributes

public export
NodeRef : Type
NodeRef = AnyPtr

public export
data DOMState = L | V

public export
data NodeType = TagNode | VoidNode | TextNode

public export
record Metadata where
  constructor MkMetadata

initMetadata : Metadata
initMetadata = MkMetadata

mutual
  public export
  data Node : (life:DOMState) -> NodeType -> Type where
    Tag  : String -> List Attribute -> List (DOM life) -> Node life TagNode
    Void : String -> List Attribute                    -> Node life VoidNode
    Text : String                                      -> Node life TextNode

  public export
  data DOM : (life:DOMState) -> Type where
    LiveDOM : Metadata -> Node L nodeType -> NodeRef -> DOM L
    VDOM    : Metadata -> Node V nodeType ->            DOM V

export
defineTag : String -> List Attribute -> List (DOM V) -> DOM V
defineTag name attrs children = VDOM initMetadata (Tag name attrs children)

export
defineVoidTag : String -> List Attribute -> DOM V
defineVoidTag name attrs = VDOM initMetadata (Void name attrs)

export
text : Show a => a -> DOM V
text string = VDOM initMetadata (Text (show string))


module Network.TLS.Certificate

import Network.TLS.Parse.DER
import Network.TLS.Parse.PEM
import Network.TLS.Parsing
import Network.TLS.Signature
import Utils.Misc
import Utils.Bytes
import Utils.IPAddr
import Data.List
import Data.Vect
import Data.Bits
import Data.String.Parser
import Data.String.Extra
import Crypto.Hash
import Decidable.Equality
import Generics.Derive

%language ElabReflection

public export
data AttributeType : Type where
  CommonName : AttributeType
  Organization : AttributeType
  OrganizationUnit : AttributeType
  Country : AttributeType
  StateOrProvince : AttributeType
  LocalityName : AttributeType
  SerialNumber : AttributeType
  UnknownAttr : List Nat -> AttributeType

%runElab derive "AttributeType" [Generic, Meta, Eq]

public export
Show AttributeType where
  show CommonName       = "CN"
  show Organization     = "O"
  show OrganizationUnit = "OU"
  show Country          = "C"
  show StateOrProvince  = "ST"
  show LocalityName     = "L"
  show SerialNumber     = "SERIALNUMBER"
  show (UnknownAttr x)  = show x

export
from_oid_attr : List Nat -> AttributeType
from_oid_attr oid =
  case map natToInteger oid of
    [ 2, 5, 4, 3 ]  => CommonName
    [ 2, 5, 4, 10 ] => Organization
    [ 2, 5, 4, 11 ] => OrganizationUnit
    [ 2, 5, 4, 6 ]  => Country
    [ 2, 5, 4, 8 ]  => StateOrProvince
    [ 2, 5, 4, 7 ]  => LocalityName
    [ 2, 5, 4, 5 ]  => SerialNumber
    _ => UnknownAttr oid

public export
record RelativeDistinguishedName where
  constructor MkRDN
  attributes : List (AttributeType, String)

public export
record DistinguishedName where
  constructor MkDN
  rdns : List RelativeDistinguishedName

public export
Eq RelativeDistinguishedName where
  a == b = (length a.attributes == length b.attributes) && ((a.attributes \\ b.attributes) == [])

public export
Eq DistinguishedName where
  a == b = a.rdns == b.rdns

export
dn_attributes : DistinguishedName -> List (AttributeType, String)
dn_attributes dn = dn.rdns >>= attributes

public export
Show DistinguishedName where
  show dn = join "," $ go <$> dn_attributes dn
    where
      go : (AttributeType, String) -> String
      go (attribute, content) = show attribute <+> "=" <+> content

extract_attr : ASN1Token -> Maybe (AttributeType, String)
extract_attr (Universal ** 16 ** Sequence [ (Universal ** 6 ** OID oid), string ]) = (from_oid_attr oid,) <$> extract_string string
extract_attr _ = Nothing

extract_rdn : ASN1Token -> Maybe RelativeDistinguishedName
extract_rdn (Universal ** 17 ** Set attributes) = MkRDN <$> traverse extract_attr attributes
extract_rdn _ = Nothing

extract_dn : ASN1Token -> Maybe DistinguishedName
extract_dn (Universal ** 16 ** Sequence rdns) = MkDN <$> traverse extract_rdn rdns
extract_dn _ = Nothing

public export
data ExtensionType : Type where
  BasicConstraint : ExtensionType
  KeyUsage : ExtensionType
  SubjectAltName : ExtensionType
  AuthorityKeyIdentifier : ExtensionType
  UnknownExt : List Nat -> ExtensionType

%runElab derive "ExtensionType" [Generic, Meta, Eq, DecEq, Show]

from_oid_ext : List Nat -> ExtensionType
from_oid_ext oid =
  case map natToInteger oid of
    [ 2, 5, 29, 15 ] => KeyUsage
    [ 2, 5, 29, 19 ] => BasicConstraint
    [ 2, 5, 29, 17 ] => SubjectAltName
    [ 2, 5, 29, 35 ] => AuthorityKeyIdentifier
    _ => UnknownExt oid

public export
record ExtBasicConstraint where
  constructor MkExtBasicConstraint
  ca : Bool
  path_len : Maybe Nat

public export
record ExtKeyUsage where
  constructor MkExtKeyUsage
  digital_signature : Bool
  non_repudiation   : Bool
  key_encipherment  : Bool
  data_encipherment : Bool
  key_agreement     : Bool
  key_cert_sign     : Bool
  crl_sign          : Bool
  encipher_only     : Bool
  decipher_only     : Bool

public export
data GeneralName : Type where
  DNSName : String -> GeneralName
  IPv4Addr : IPv4Addr -> GeneralName
  IPv6Addr : IPv6Addr -> GeneralName
  UnknownGN : ASN1Token -> GeneralName

public export
Show GeneralName where
  show (DNSName dns_name) = "DNS: " <+> dns_name
  show (IPv4Addr addr) = "IP Address: " <+> show addr
  show (IPv6Addr addr) = "IP Address: " <+> show addr
  show (UnknownGN _) = "<unknown>"

public export
Eq GeneralName where
  (DNSName a)  == (DNSName b) = a == b
  (IPv4Addr a) == (IPv4Addr b) = a == b
  (IPv6Addr a) == (IPv6Addr b) = a == b
  _ == _ = False

extract_general_name : ASN1Token -> Either String GeneralName
extract_general_name (ContextSpecific ** 2 ** UnknownPrimitive _ _ str) = Right $ DNSName $ ascii_to_string str
extract_general_name (ContextSpecific ** 7 ** UnknownPrimitive _ _ str) =
  let vec = fromList str
      gn = (IPv4Addr . MkIPv4Addr <$> exactLength 4 vec) <|> (IPv6Addr . MkIPv6Addr <$> exactLength 16 vec)
  in maybe_to_either gn "invalid IP address"
extract_general_name x = Right $ UnknownGN x

public export
record ExtSubjectAltName where
  constructor MkExtSubjectAltName
  general_names : List GeneralName

public export
record ExtAuthorityKeyIdentifier where
  constructor MkExtAuthorityKeyIdentifier
  key_identifier : Maybe (Vect 20 Bits8)
  general_names : List GeneralName
  serial_number : Maybe Integer

extract_auth_key_id : List ASN1Token -> Either String (List ASN1Token, Maybe (Vect 20 Bits8))
extract_auth_key_id [] = Right ([], Nothing)
extract_auth_key_id ((ContextSpecific ** 0 ** UnknownPrimitive _ _ key) :: xs) =
  (\c => (xs, Just c)) <$> (maybe_to_either (exactLength 20 $ fromList key) "invalid key id length")
extract_auth_key_id (x :: xs) = Right ((x :: xs), Nothing)

extract_auth_general_names : List ASN1Token -> Either String (List ASN1Token, List GeneralName)
extract_auth_general_names [] = Right ([], [])
extract_auth_general_names ((ContextSpecific ** 1 ** UnknownConstructed _ _ gns) :: xs) =
  (xs,) <$> traverse extract_general_name gns
extract_auth_general_names (x :: xs) = Right ((x :: xs), [])

extract_auth_serial_no : List ASN1Token -> Either String (Maybe Integer)
extract_auth_serial_no [] = Right Nothing
extract_auth_serial_no ((ContextSpecific ** 2 ** UnknownPrimitive _ _ serial_no) :: []) = do
  let (Pure [] ok) = feed (map (uncurry MkPosed) $ enumerate Z serial_no) (parse_integer $ length serial_no)
  | (Pure leftover _) => Left $ "malformed serial number: leftover: " <+> (xxd $ map get leftover)
  | (Fail err) => Left $ show err
  | _ => Left "malformed serial number: underfed"
  pure $ Just ok
extract_auth_serial_no (x :: []) = Right Nothing
extract_auth_serial_no (x :: (y :: ys)) = Left "serial number is followed by unrecognized field"

public export
extension_type : ExtensionType -> Type
extension_type BasicConstraint = ExtBasicConstraint
extension_type KeyUsage = ExtKeyUsage
extension_type SubjectAltName = ExtSubjectAltName
extension_type AuthorityKeyIdentifier = ExtAuthorityKeyIdentifier
extension_type _ = List Bits8

parse_to_extension_type : (t : ExtensionType) -> List Bits8 -> Either String (extension_type t)
parse_to_extension_type BasicConstraint body = do
  let (Pure [] ok) = feed (map (uncurry MkPosed) $ enumerate Z body) parse_asn1
  | (Pure leftover _) => Left $ "malformed basic constraint ext: leftover: " <+> (xxd $ map get leftover)
  | (Fail err) => Left $ show err
  | _ => Left "malformed basic constraint: underfed"
  let ( Universal ** 16 ** Sequence content ) = ok
  | _ => Left "malformed basic constraint: structure error"
  case content of
    [] =>
      Right (MkExtBasicConstraint False Nothing)
    [ (Universal ** 1 ** Boolean ca) ] =>
      Right (MkExtBasicConstraint ca Nothing)
    [ (Universal ** 1 ** Boolean ca), (Universal ** 2 ** IntVal depth) ] =>
      Right (MkExtBasicConstraint ca $ Just $ integerToNat depth)
    _ =>
      Left "malformed basic constraint: structure error"
parse_to_extension_type KeyUsage body = do
  let (Pure [] ok) = feed (map (uncurry MkPosed) $ enumerate Z body) parse_asn1
  | (Pure leftover _) => Left $ "malformed key usage ext: leftover: " <+> (xxd $ map get leftover)
  | (Fail err) => Left $ show err
  | _ => Left "malformed key usage: underfed"
  let (Universal ** 3 ** Bitstring content) = ok
  | _ => Left "malformed key usage: structure error"
  case take 9 ((content.bytes >>= (toList . to_bools_be)) <+> replicate 9 False) of
    [a, b, c, d, e, f, g, h, i] => Right $ MkExtKeyUsage a b c d e f g h i
    _ => Left "impossible"
parse_to_extension_type SubjectAltName body = do
  let (Pure [] ok) = feed (map (uncurry MkPosed) $ enumerate Z body) parse_asn1
  | (Pure leftover _) => Left $ "malformed subject alt name ext: leftover: " <+> (xxd $ map get leftover)
  | (Fail err) => Left $ show err
  | _ => Left "malformed subject alt name: underfed"
  let (Universal ** 16 ** Sequence content) = ok
  | _ => Left "malformed subject alt name: structure error"
  MkExtSubjectAltName <$> traverse extract_general_name content
parse_to_extension_type AuthorityKeyIdentifier body = do
  let (Pure [] ok) = feed (map (uncurry MkPosed) $ enumerate Z body) parse_asn1
  | (Pure leftover _) => Left $ "malformed subject authority key id ext: leftover: " <+> (xxd $ map get leftover)
  | (Fail err) => Left $ show err
  | _ => Left "malformed subject authority key id: underfed"
  let (Universal ** 16 ** Sequence content) = ok
  | _ => Left "malformed subject authority key id: structure error"

  (content, key_id) <- extract_auth_key_id content
  (content, gns) <- extract_auth_general_names content
  sn <- extract_auth_serial_no content
  pure $ MkExtAuthorityKeyIdentifier key_id gns sn

parse_to_extension_type (UnknownExt x) body = Right body

public export
record Extension where
  constructor MkExt
  extension_id : ExtensionType
  critical : Bool
  value : extension_type extension_id

extract_extensions : List ASN1Token -> Either String (List Extension)
extract_extensions [] = Right []
extract_extensions (x :: xs) =
  case last (x :: xs) of
    (ContextSpecific ** 3 ** UnknownConstructed _ _ [ (Universal ** 16 ** Sequence extensions) ]) => traverse extract_ext extensions
    _ => Left "malformed extension list field"
  where
    extract_ext : ASN1Token -> Either String Extension
    extract_ext (Universal ** 16 ** Sequence
                [ (Universal ** 6 ** OID oid)
                , (Universal ** 1 ** Boolean critical)
                , (Universal ** 4 ** OctetString value)
                ]) = let ext_id = from_oid_ext oid in (MkExt ext_id critical) <$> parse_to_extension_type ext_id value
    extract_ext (Universal ** 16 ** Sequence
                [ (Universal ** 6 ** OID oid)
                , (Universal ** 4 ** OctetString value)
                ]) = let ext_id = from_oid_ext oid in (MkExt ext_id False) <$> parse_to_extension_type ext_id value
    extract_ext _ = Left "malformed extension field"

public export
record Certificate where
  constructor MkCertificate
  serial_number : Integer
  issuer : DistinguishedName
  valid_not_before : Integer
  valid_not_after : Integer
  subject : DistinguishedName
  cert_public_key : PublicKey
  cert_public_key_id : Vect 20 Bits8
  sig_parameter : SignatureParameter
  signature_value : BitArray
  extensions : List Extension
  tbs_raw_bytes : List Bits8

public export
Show Certificate where
  show cert = "Subject: " <+> show cert.subject <+> " Issuer: " <+> show cert.issuer

export
certificate_subject_names : Certificate -> List GeneralName
certificate_subject_names cert = go (toList (DNSName <$> common_name)) cert.extensions
  where
    go : List GeneralName -> List Extension -> List GeneralName
    go acc [] = acc
    go acc (x :: xs) =
      case x of
        MkExt SubjectAltName _ ext => go (acc <+> ext.general_names) xs
        _ => go acc xs
    common_name : Maybe String
    common_name = lookup CommonName $ dn_attributes cert.subject

export
is_self_signed : Certificate -> Bool
is_self_signed cert = cert.issuer == cert.subject

export
extract_extension : (type : ExtensionType) -> Certificate -> Maybe (extension_type type)
extract_extension type cert = go type cert.extensions
  where
    go : (type : ExtensionType) -> List Extension -> Maybe (extension_type type)
    go type (extension :: xs) =
      case decEq type extension.extension_id of
        Yes ok => Just $ rewrite ok in extension.value
        No _ => go type xs
    go type [] = Nothing

extract_tbs_raw_bytes : List Bits8 -> Either String (List Bits8)
extract_tbs_raw_bytes blob = do
  -- trim outer most layer
  let (Pure outer _) = feed (map (uncurry MkPosed) $ enumerate Z blob) (parse_tag_id *> parse_length)
  | (Fail err) => Left $ show err
  | _ => Left "malformed certificate: underfed"
  -- get the inner information
  let (Pure inner len) = feed outer (parse_tag_id *> parse_length)
  | (Fail err) => Left $ show err
  | _ => Left "malformed tbs certificate: underfed"

  let metadata = take (minus (length outer) (length inner)) outer
  pure (map get metadata <+> map get (take len inner))

export
parse_certificate : List Bits8 -> Either String Certificate
parse_certificate blob = do
  let (Pure [] ok) = feed (map (uncurry MkPosed) $ enumerate Z blob) parse_asn1
  | (Pure leftover _) => Left $ "malformed certificate: leftover: " <+> (xxd $ map get leftover)
  | (Fail err) => Left $ show err
  | _ => Left "malformed certificate: underfed"

  let (Universal ** 16 ** Sequence
        [ (Universal ** 16 ** Sequence
          ( (ContextSpecific ** 0 ** UnknownConstructed _ _ [ (Universal ** 2 ** IntVal 2) ])
          :: (Universal ** 2 ** IntVal serial_number)
          :: crt_algorithm
          :: issuer
          :: (Universal ** 16 ** Sequence valid_period)
          :: subject
          :: certificate_public_key
          :: optional_fields
          ))
        , crt_signature_algorithm
        , (Universal ** 3 ** Bitstring signature_value)
        ]
      ) = ok
  | _ => Left "malformed certificate"

  let Just [ valid_not_before, valid_not_after ] = traverse {f=Maybe} extract_epoch valid_period
  | _ => Left "malformed validity timestamp"

  (key_id, key) <- extract_key' certificate_public_key

  crt_algorithm <- maybe_to_either (extract_algorithm crt_algorithm) "malformed certificate algorithm"
  crt_signature_algorithm <- maybe_to_either (extract_algorithm crt_signature_algorithm) "malformed certificate signature algorithm"

  let True = fst crt_algorithm == fst crt_signature_algorithm
  | False => Left "tbsCertificate signature field does not match signature algorithm"

  sig_param <- uncurry extract_signature_parameter crt_algorithm

  issuer <- maybe_to_either (extract_dn issuer) "malformed issuer"
  subject <- maybe_to_either (extract_dn subject) "malformed subject"

  extensions <- extract_extensions optional_fields

  raw_tbs_bytes <- extract_tbs_raw_bytes blob

  pure $
    MkCertificate
      serial_number
      issuer
      valid_not_before
      valid_not_after
      subject
      key
      key_id
      sig_param
      signature_value
      extensions
      raw_tbs_bytes


||| Adding colours to the adventure game
||| Ported from https://www.linuxjournal.com/content/programming-color-ncurses

module AdventureInColor

import Data.Nat
import NCurses

%default covering

-- Define symbols for the map
grass    = ' '
empty    = '.'
water    = '~'
mountain = '^'
player   = '*'

isMoveOkay : Position -> NCurses i i Bool
isMoveOkay pos = do c <- mvInCh pos
                    pure (c == grass || c == empty)

CFG = MkConfig
  { noDelayEnabled = False
  , keypadEnabled  = True
  , colorEnabled   = True
  }

main : IO ()
main = runNCurses $ NCurses.do
  -- Initialise curses
  cBreak
  noEcho
  clear
  keypad True
  startColor

  -- Grab size
  size <- getSize

  -- Initialise the colors
  grassC    <- initColorPair 1 Yellow Green
  waterC    <- initColorPair 2 Cyan   Blue
  mountainC <- initColorPair 3 Black  White
  playerC   <- initColorPair 4 Red    Magenta

  -- Draw map
  -- background
  nSetAttr (CP grassC)
  for_ @{NCURSES} [0..size.height] $ \ row =>
    mvHLine (MkRow row) grass size.width

  -- mountain
  nSetAttr (CP mountainC)
  for_ @{NCURSES} [half size.width .. threequarter size.width] $ \ col =>
    mvVLine (MkPosition { row = 0, col }) mountain size.height

  -- mountain path
  nSetAttr (CP grassC)
  mvHLine (MkRow $ quarter size.height) grass size.width

  -- lake
  nSetAttr (CP waterC)
  for_ @{NCURSES} [1..half size.height] $ \ row =>
    mvHLine (MkPosition { row, col = 1 }) water (third size.width)

  -- wait for the user quitting
  exploring playerC grassC size (MkRow $ pred size.height)

  where

    quarter : Nat -> Nat
    quarter n = (n `divNatNZ` 4) %search

    third : Nat -> Nat
    third n = (n `divNatNZ` 3) %search

    half : Nat -> Nat
    half n = (n `divNatNZ` 2) %search

    threequarter : Nat -> Nat
    threequarter n = (3 * n `divNatNZ` 4) %search

    step : ColorPair -> (pos, pos' : Position) -> NCurses CFG CFG Position
    step emptyC pos pos'
      = do ok <- isMoveOkay pos'
           ifThenElse (not ok) (pure pos) $ do
             nSetAttr (CP emptyC)
             mvAddCh pos empty
             pure pos'

    exploring : (playerC, emptyC : ColorPair) ->
                Size -> Position -> NCurses CFG CFG ()
    exploring playerC emptyC sz pos@(MkPosition { row, col }) = NCurses.do
      -- display player at position
        nSetAttr (CP playerC)
        mvAddCh pos player
        move pos
        refresh
        -- wait for an input to move
        Left c <- getCh
          | Right 'q' => pure () -- quitting
          | Right _ => exploring playerC emptyC sz pos -- invalid input
        case c of
          Up    => do pos <- step emptyC pos (up pos)
                      exploring playerC emptyC sz pos
          Down  => do let pos' = down pos
                      let True = pos'.row < pred sz.height
                        | _ => exploring playerC emptyC sz pos
                      pos <- step emptyC pos pos'
                      exploring playerC emptyC sz pos
          Left  => do pos <- step emptyC pos (left pos)
                      exploring playerC emptyC sz pos
          Right => do let pos' = right pos
                      let True = pos'.col < pred sz.width
                        | _ => exploring playerC emptyC sz pos
                      pos <- step emptyC pos pos'
                      exploring playerC emptyC sz pos
          _ => exploring playerC emptyC sz pos -- invalid input


-- Module      : Itea.Program
-- Description :
-- Copyright   : (c) Simon Nielsen Knights 2018
-- License     : MIT
-- Maintainer  : simonank@mail.ru
-- Stability   : unstable
-- Portability : portable

module Itea.Program
import Itea.Html
import Itea.Dom.Primitives

%default total
%access public export

||| Commands
data Cmd : Type -> Type where

||| Subscriptions
data Sub : Type -> Type where

||| Data representation of the program which carries all information
||| to run the applicationg indefinetly
|||
||| @model the used supplied model (state) for the program
||| @msg the message type representing user actions
record Program model msg where
  constructor MkProgram
  ||| Initial state
  init          : (model, Cmd msg)
  ||| Update function used to advance state by one step
  update        : msg -> model -> (model, Cmd msg)
  ||| Subscription to services which fire events upon completion
  subscriptions : model -> Sub msg
  ||| View constructing the DOM tree
  view          : model -> Html msg

runProgram : Program model msg -> JS_IO ()
runProgram (MkProgram init update subscriptions view) = loop init

  where

    -- The main event loop handles fetching events from the event
    -- queue, values from subscriptions. This provides the interface
    -- where we focus on events over time rather than having to deal
    -- explicitly with the looping details ourselves.
    loop : (model, Cmd msg) -> JS_IO ()
    loop =
      do ?k
         -- setTimeout (loop ?p) 50
         -- pure ()


module Utils.Handle

import Data.Vect
import Data.Nat
import Control.Monad.Error.Either
import Control.Linear.LIO

public export
ReadHack : (t_ok : Type) -> (t_read_failed : Type) -> Bool -> Type
ReadHack t_ok t_read_failed False = t_read_failed
ReadHack t_ok t_read_failed True = Res (List Bits8) (const t_ok)

public export
WriteHack : (t_ok : Type) -> (t_write_failed : Type) -> Bool -> Type
WriteHack t_ok t_write_failed False = t_write_failed
WriteHack t_ok t_write_failed True = t_ok

public export
record Handle (t_ok : Type) (t_closed : Type) (t_read_failed : Type) (t_write_failed : Type) where
  constructor MkHandle
  1 underlying : t_ok
  do_read : forall m. LinearIO m => (1 _ : t_ok) -> (len : Nat) -> L1 m $ Res Bool $ ReadHack t_ok t_read_failed
  do_write : forall m. LinearIO m => (1 _ : t_ok) -> List Bits8 -> L1 m $ Res Bool $ WriteHack t_ok t_write_failed
  do_close : forall m. LinearIO m => (1 _ : t_ok) -> L1 m t_closed

public export
close : LinearIO m => (1 _ : Handle t_ok t_closed t_read_failed t_write_failed) -> L1 m t_closed
close (MkHandle x do_read do_write do_close) = do_close x

public export
read : LinearIO m => (1 _ : Handle t_ok t_closed t_read_failed t_write_failed) -> (len : Nat) -> L1 m $ Res Bool $ \case
  False => t_read_failed
  True => Res (List Bits8) (\_ => Handle t_ok t_closed t_read_failed t_write_failed)
read (MkHandle x do_read do_write do_close) len = do
  (True # (output # x)) <- do_read x len
  | (False # x) => pure1 $ False # x
  pure1 $ True # (output # MkHandle x do_read do_write do_close)

public export
write : LinearIO m => (1 _ : Handle t_ok t_closed t_read_failed t_write_failed) -> (input : List Bits8) -> L1 m $ Res Bool $ \case
  False => t_write_failed
  True => Handle t_ok t_closed t_read_failed t_write_failed
write (MkHandle x do_read do_write do_close) input = do
  (True # x) <- do_write x input
  | (False # x) => pure1 $ False # x
  pure1 $ True # MkHandle x do_read do_write do_close

public export
Handle' : Type -> Type -> Type
Handle' t_ok t_closed = Handle t_ok t_closed (Res String $ const t_closed) (Res String $ const t_closed)


module System.File.Permissions

import public System.File.Error
import System.File.Meta
import System.File.Support
import public System.File.Types
import System.FFI

%default total

fileClass : String
fileClass = "io/github/mmhelloworld/idrisjvm/runtime/ChannelIo"

%foreign support "idris2_chmod"
         "node:support:chmod,support_system_file"
         jvm' fileClass "chmod" "String int" "int"
prim__chmod : String -> Int -> PrimIO Int

namespace FileMode
  public export
  data FileMode = Read | Write | Execute

public export
record Permissions where
  constructor MkPermissions
  user   : List FileMode
  group  : List FileMode
  others : List FileMode

mkMode : Permissions -> Int
mkMode p
    = getMs (user p) * 64 + getMs (group p) * 8 + getMs (others p)
  where
    getM : FileMode -> Int
    getM Read = 4
    getM Write = 2
    getM Execute = 1

    getMs : List FileMode -> Int
    getMs = sum . map getM

export
chmodRaw : HasIO io => String -> Int -> io (Either FileError ())
chmodRaw fname p
    = do ok <- primIO $ prim__chmod fname p
         if ok == 0
            then pure (Right ())
            else returnError

export
chmod : HasIO io => String -> Permissions -> io (Either FileError ())
chmod fname p = chmodRaw fname (mkMode p)