text:
module Bautzen.Game.Move

import Bautzen.Game.Core
import Bautzen.GameUnit
import Bautzen.Pos
import Bautzen.Terrain
import Bautzen.ZoC

import Data.List.Extra as List
import Data.Nat.Extra

import Data.List
import Data.Maybe
import Data.Nat

public export
updateMovedUnit : (unit : GameUnit) -> Pos -> (mps : Nat) -> { auto prf : LTE mps (currentMP unit) } -> List (GameUnit, Pos) -> List (GameUnit, Pos)
updateMovedUnit unit newPosition mps = foldr updateUnit []
  where
    newMP : Nat
    newMP = currentMP unit - mps

    updateUnit : (GameUnit, Pos) -> List (GameUnit, Pos) -> List (GameUnit, Pos)
    updateUnit (gu, pos) acc =
      if fullName unit == fullName gu
      then (record { currentMP = newMP } unit, newPosition) :: acc
      else (gu, pos) :: acc

public export
movementCost : (unit : GameUnit) -> (units : List (GameUnit, Pos)) -> (gameMap : Map) -> (from : Pos) -> (to : Pos)
             -> Bool
             -> Either GameError (cost : Cost ** LTE (toNat cost) (currentMP unit))
movementCost unit units gameMap from to leavingZoC with (cost (unitType unit) (terrain to gameMap) (connection from to gameMap))
  movementCost unit units _ from to _     | Impossible = Left (ForbiddenTerrain from to)
  movementCost unit units _ from to False | c = case isLTE (toNat c) (currentMP unit) of
                                                           Yes prf => Right (c ** prf)
                                                           No _    => Left (NotEnoughMPs unit from to (toNat c))
  movementCost unit units _ from to True  | c = let cost = One c
                                                in case isLTE (toNat cost) (currentMP unit) of
                                                           Yes prf => Right (cost ** prf)
                                                           No _    => Left (NotEnoughMPs unit from to (toNat cost))

public export
moreMoveTo : (unit : GameUnit) -> (units : List (GameUnit, Pos)) -> (gameMap : Map) -> (from : Pos) -> (to : Pos) -> Either GameError Event
moreMoveTo unit units gameMap from to with (inZoC (side (nation unit)) units from, inZoC (side (nation unit)) units to)
  moreMoveTo unit units gameMap from to | (InZoC _, Free) = do (c ** _) <- movementCost unit units gameMap from to True
                                                               pure (Moved unit from to c)
  moreMoveTo unit units gameMap from to | (Free, _) = do (c ** _) <- movementCost unit units gameMap from to False
                                                         pure (Moved unit from to c)
  moreMoveTo unit units gameMap from to | (_, _) = Left (MoveFromZocToZoc unit to)

public export
sameName : String -> (GameUnit, Pos) -> Bool
sameName unitName (u,_) = fullName u == unitName

public export
samePosition : Pos -> (GameUnit, Pos) -> Bool
samePosition to (_,p) = p == to

public export
moveTo : (side : Side) -> (units : List (GameUnit, Pos)) -> Map -> (unitName : String) -> (to : Pos) -> Either GameError Event
moveTo sideToPlay units gameMap unitName to =
  case find' (sameName unitName) units of
    (Just (unit, b)) => if side (nation unit) /= sideToPlay
                        then Left (NotYourTurn (side (nation unit)))
                        else if not (to `elem` (neighbours b))
                             then Left (InvalidMove b to)
                             else case find' (samePosition to) units of
                                       Nothing => moreMoveTo unit units gameMap b to
                                       (Just (other, _)) => if friendly (nation unit) (nation other)
                                                            then moreMoveTo unit units gameMap b to
                                                            else Left (EnemyInHex other to)
    Nothing => Left (NoSuchUnits [unitName])

-- namespace MoveTest

--   cannot_move_if_unit_does_not_exist : moveTo Allies [ (Bautzen.GameUnit.p13_5dp, Hex 3 4) ] TestMap "foo" (Hex 3 5) = Left (NoSuchUnits [ "foo" ])
--   cannot_move_if_unit_does_not_exist = Refl

--   cannot_move_not_current_side : moveTo Axis [ (Bautzen.GameUnit.p13_5dp, Hex 3 4) ] TestMap "13/5DP" (Hex 3 5) = Left (NotYourTurn Allies)
--   cannot_move_not_current_side = Refl

--   cannot_move_if_target_hex_is_occupied_by_enemy : moveTo Allies [ (Bautzen.GameUnit.p13_5dp, Hex 3 4), (Bautzen.GameUnit.g21_20pz, Hex 3 5) ] TestMap "13/5DP" (Hex 3 5) = Left (EnemyInHex Bautzen.GameUnit.g21_20pz (Hex 3 5))
--   cannot_move_if_target_hex_is_occupied_by_enemy = Refl

--   cannot_move_from_zoc_to_zoc : moveTo Allies [ (Bautzen.GameUnit.p13_5dp, Hex 3 4), (Bautzen.GameUnit.g21_20pz, Hex 3 5) ] TestMap "13/5DP" (Hex 4 5) = Left (MoveFromZocToZoc Bautzen.GameUnit.p13_5dp (Hex 4 5))
--   cannot_move_from_zoc_to_zoc = Refl

--   moving_into_clear_terrain_costs_1 : moveTo Allies [ (Bautzen.GameUnit.p13_5dp, Hex 3 4) ] TestMap "13/5DP" (Hex 4 4) = Right (Moved Bautzen.GameUnit.p13_5dp (Hex 3 4) (Hex 4 4) (One Zero))
--   moving_into_clear_terrain_costs_1 = Refl

--   infantry_moving_into_rough_terrain_costs_1 : moveTo Allies [ (Bautzen.GameUnit.p13_5dp, Hex 3 4) ] TestMap "13/5DP" (Hex 3 3) = Right (Moved Bautzen.GameUnit.p13_5dp (Hex 3 4) (Hex 3 3) (One Zero))
--   infantry_moving_into_rough_terrain_costs_1 = Refl

--   non_infantry_moving_into_rough_terrain_costs_2 : moveTo Axis [ (Bautzen.GameUnit.g21_20pz, Hex 3 4) ] TestMap "21/20Pz" (Hex 3 3) = Right (Moved Bautzen.GameUnit.g21_20pz (Hex 3 4) (Hex 3 3) (Two Zero))
--   non_infantry_moving_into_rough_terrain_costs_2 = Refl

--   cost_for_rough_is_cumulative : moveTo Allies [ (Bautzen.GameUnit.p13_5dp, Hex 3 4) ] TestMap "13/5DP" (Hex 3 5) = Right (Moved Bautzen.GameUnit.p13_5dp (Hex 3 4) (Hex 3 5) (One (One Zero)))
--   cost_for_rough_is_cumulative = Refl

--   armored_cost_for_rough_is_cumulative : moveTo Axis [ (Bautzen.GameUnit.g21_20pz, Hex 3 4) ] TestMap "21/20Pz" (Hex 3 5) = Right (Moved Bautzen.GameUnit.g21_20pz (Hex 3 4) (Hex 3 5) (Two (Two Zero)))
--   armored_cost_for_rough_is_cumulative = Refl

--   moving_across_a_lake_is_forbidden : moveTo Axis [ (Bautzen.GameUnit.g21_20pz, Hex 8 6) ] TestMap "21/20Pz" (Hex 8 7) = Left (ForbiddenTerrain (Hex 8 6) (Hex 8 7))
--   moving_across_a_lake_is_forbidden = Refl

--   armored_moving_on_hill_is_forbidden : moveTo Axis [ (Bautzen.GameUnit.g21_20pz, Hex 3 4) ] TestMap "21/20Pz" (Hex 4 5) = Left (ForbiddenTerrain (Hex 3 4) (Hex 4 5))
--   armored_moving_on_hill_is_forbidden = Refl

--   armored_moving_on_hill_through_road_costs_half : moveTo Axis [ (Bautzen.GameUnit.g21_20pz, Hex 8 7) ] TestMap "21/20Pz" (Hex 7 7) = Right (Moved Bautzen.GameUnit.g21_20pz (Hex 8 7) (Hex 7 7) (Half (Two Zero)))
--   armored_moving_on_hill_through_road_costs_half = Refl

--   armored_moving_through_road_costs_half : moveTo Axis [ (Bautzen.GameUnit.g21_20pz, Hex 4 4) ] TestMap "21/20Pz" (Hex 5 4) = Right (Moved Bautzen.GameUnit.g21_20pz (Hex 4 4) (Hex 5 4) (Half (One Zero)))
--   armored_moving_through_road_costs_half = Refl

--   infantry_moving_through_road_costs_half : moveTo Allies [ (Bautzen.GameUnit.p13_5dp, Hex 8 7) ] TestMap "13/5DP" (Hex 7 7) = Right (Moved Bautzen.GameUnit.p13_5dp (Hex 8 7) (Hex 7 7) (Half (Two (One Zero))))
--   infantry_moving_through_road_costs_half = Refl

--   river_adds_one_PM_to_move : moveTo Allies [ (Bautzen.GameUnit.p13_5dp, Hex 10 3) ] TestMap "13/5DP" (Hex 10 2) = Right (Moved Bautzen.GameUnit.p13_5dp (Hex 10 3) (Hex 10 2) (Half (One (One (One Zero)))))
--   river_adds_one_PM_to_move = Refl

--   moving_out_of_ZoC_adds_one_PM_to_move : moveTo Allies [ (Bautzen.GameUnit.p13_5dp, Hex 3 4), (Bautzen.GameUnit.g21_20pz, Hex 3 5) ] TestMap "13/5DP" (Hex 4 4) = Right (Moved Bautzen.GameUnit.p13_5dp (Hex 3 4) (Hex 4 4) (One (One Zero)))
--   moving_out_of_ZoC_adds_one_PM_to_move = Refl

--   g21_20pz_no_mp : GameUnit
--   g21_20pz_no_mp = record { currentMP = 3 } GameUnit.g21_20pz

--   unit_cannot_move_if_not_enough_MP : moveTo Axis [ (MoveTest.g21_20pz_no_mp, Hex 3 4) ] TestMap "21/20Pz" (Hex 3 5) = Left (NotEnoughMPs MoveTest.g21_20pz_no_mp (Hex 3 4) (Hex 3 5) 4)
--   unit_cannot_move_if_not_enough_MP = Refl

--   cannot_move_more_than_one_hex : moveTo Axis [ (Bautzen.GameUnit.g21_20pz, Hex 3 4) ] TestMap "21/20Pz" (Hex 3 6) = Left (InvalidMove (Hex 3 4) (Hex 3 6))
--   cannot_move_more_than_one_hex = Refl

ext: idr

max_stars_repo_name: steshaw/hsgames

max_issues_repo_name: steshaw/hsgames

max_forks_repo_name: steshaw/hsgames

lm_label:
1. YES
2. NO


text:
module Network.TLS.Verify

import Network.TLS.Core
import Network.TLS.Certificate
import Network.TLS.Signature
import Network.TLS.Handshake
import Network.TLS.Parse.DER
import Utils.Misc
import Utils.Bytes
import Data.String
import Data.List
import Data.List.Lazy
import Data.List1
import Data.Vect
import Utils.IPAddr
import Data.Either
import System
import Control.Monad.Error.Either
import Control.Monad.Trans

%hide Network.TLS.Handshake.Message.Certificate

||| Takes a wildcard domain like "*.google.com" and creates
||| a function to check if a string matches the wildcard domain
domain_predicate : String -> Maybe (String -> Bool)
domain_predicate predicate = do
  let parts = split ('.' ==) predicate
  guard $ verify_predicate parts
  Just (apply_predicate parts . split ('.' == ))
  where
    str_eq : String -> String -> Lazy Bool
    str_eq "*" _ = delay True
    str_eq _ "*" = delay True
    str_eq a b = delay (a == b)
    apply_predicate : List1 String -> List1 String -> Bool
    apply_predicate a b = (length a == length b) && (and $ zipWith str_eq a b)
    verify_predicate : List1 String -> Bool
    verify_predicate ("*" ::: []) = False
    verify_predicate ("*" ::: [_]) = False
    verify_predicate ("*" ::: [_, ""]) = False
    verify_predicate ("*" ::: xs) = and $ map (delay . not . isInfixOf "*") xs
    verify_predicate xs = and $ map (delay . not . isInfixOf "*") (toList xs)

domain_predicate' : String -> (String -> Bool)
domain_predicate' predicate =
  case domain_predicate predicate of
    Nothing => const False
    Just f => f

||| Type of identifier that will be used to check if a certificate's common name matches
||| the supplied hostname
Identifier : Type
Identifier = Eithers [IPv4Addr, IPv6Addr, String]

check_ipv4_address : List GeneralName -> IPv4Addr -> Bool
check_ipv4_address (IPv4Addr addr' :: xs) addr = if addr == addr' then True else check_ipv4_address xs addr
check_ipv4_address (x :: xs) addr = check_ipv4_address xs addr
check_ipv4_address [] _ = False

check_ipv6_address : List GeneralName -> IPv6Addr -> Bool
check_ipv6_address (IPv6Addr addr' :: xs) addr = if addr == addr' then True else check_ipv6_address xs addr
check_ipv6_address (x :: xs) addr = check_ipv6_address xs addr
check_ipv6_address [] _ = False

check_dns_name : List GeneralName -> String -> Bool
check_dns_name (DNSName predicate :: xs) name = if (domain_predicate' predicate) name then True else check_dns_name xs name
check_dns_name (x :: xs) name = check_dns_name xs name
check_dns_name [] _ = False

||| Check if the certificate has expired
check_cert_timestamp : HasIO io => Certificate -> io Bool
check_cert_timestamp cert = (\t => t > cert.valid_not_before && t < cert.valid_not_after) <$> time

||| Find a certificate with matching common name given an identifier
find_certificate : Identifier -> List Certificate -> Maybe Certificate
find_certificate identifier certs = choice $ map (delay . is_certificate identifier) certs
  where
    is_certificate : Identifier -> Certificate -> Maybe Certificate
    is_certificate (Left x)          cert = guard (check_ipv4_address (certificate_subject_names cert) x) $> cert
    is_certificate (Right (Left x))  cert = guard (check_ipv6_address (certificate_subject_names cert) x) $> cert
    is_certificate (Right (Right x)) cert = guard (check_dns_name (certificate_subject_names cert) x) $> cert

||| Convert a string of hostname into an identifier, such as DNSName, IPv4 and IPv6 address
to_identifier : String -> Identifier
to_identifier hostname =
  case parse_ipv4 hostname of
    Right x => Left x
    Left _ =>
      case parse_ipv6 hostname of
        Right x => Right (Left x)
        Left _ => Right (Right hostname)

||| Check if the server's certificate is valid
check_leaf_certificate : HasIO io => Certificate -> EitherT String io ()
check_leaf_certificate cert = do
  True <- check_cert_timestamp cert
  | False => throwE $ "expired certificate: " <+> show cert
  let Just key_usage = extract_extension KeyUsage cert
  | Nothing => throwE $ "certificate does not specify key usage: " <+> show cert
  let True = key_usage.digital_signature
  | False => throwE $ "certificate key usage does not allow digital signature: " <+> show cert
  pure ()

||| Check if the server's certificate's ca and intermediate ca's are valid
||| depth refers to how deep you are in the certificate chain, needed since
||| some intermediate ca's specify a constraint on the maximum depth
check_branch_certificate : HasIO io => Nat -> Certificate -> EitherT String io ()
check_branch_certificate depth cert = do
  True <- check_cert_timestamp cert
  | False => throwE $ "expired certificate: " <+> show cert
  let Just key_usage = extract_extension KeyUsage cert
  | Nothing => throwE $ "certificate does not specify key usage: " <+> show cert
  let Just basic_constraint = extract_extension BasicConstraint cert
  | Nothing => throwE $ "certificate does not specify basic constraint: " <+> show cert
  let True = basic_constraint.ca
  | False => throwE $ "certificate is not a CA: " <+> show cert
  let True = basic_constraint.path_len `cmp` depth
  | False => throwE $ "certificate CA depth reached: " <+> show cert
  let True = key_usage.key_cert_sign
  | False => throwE $ "certificate key usage does not allow signing certificates: " <+> show cert
  pure ()
  where
    cmp : Maybe Nat -> Nat -> Bool
    cmp Nothing _ = True
    cmp (Just a) b = b <= a

||| Given a certificate and its issuer's certificate, verify if the certificate's signature is correct
verify_certificate_signature : Certificate -> Certificate -> Either String ()
verify_certificate_signature subject issuer = bimap ("error at \{show subject}: " <+>) id $
  verify_signature' subject.sig_parameter issuer.cert_public_key subject.tbs_raw_bytes subject.signature_value

||| True if there is intersecting elements in both list
has_intersect : Eq a => List a -> List a -> Bool
has_intersect [] y = False
has_intersect x [] = False
has_intersect (x :: xs) y = if any (x ==) y then True else has_intersect xs y

||| Given an Authority Key Identifier extension, verifies if another certificate matches the constraint
||| This is needed since in the case that a certificate is cross signed by another CA, issuer and subject
||| distinguished names are not sufficient to find a subject's issuer.
auth_key_id_predicate : ExtAuthorityKeyIdentifier -> (Certificate -> Bool)
auth_key_id_predicate (MkExtAuthorityKeyIdentifier Nothing [] Nothing) = const False
auth_key_id_predicate auth_key_id = go auth_key_id
  where
    def : Maybe Bool -> Bool
    def Nothing = True
    def (Just a) = a
    -- Check if the SHA1 hash of public keys match
    go0 : ExtAuthorityKeyIdentifier -> Certificate -> Bool
    go0 auth_key_id cert = def (map (\i => i == cert.cert_public_key_id) auth_key_id.key_identifier)
    -- Check if the serial number matches
    go1 : ExtAuthorityKeyIdentifier -> Certificate -> Bool
    go1 auth_key_id cert = def (map (\i => i == cert.serial_number) auth_key_id.serial_number)
    -- Check if the subject distinguished names match
    go2 : ExtAuthorityKeyIdentifier -> Certificate -> Bool
    go2 auth_key_id cert =
      case auth_key_id.general_names of
        [] => True
        gn => has_intersect gn $ certificate_subject_names cert
    go : ExtAuthorityKeyIdentifier -> Certificate -> Bool
    go a b = go0 a b && go1 a b && go2 a b

flatten : Maybe (LazyList a) -> LazyList a
flatten Nothing = []
flatten (Just a) = a

liftE : Monad m => Either a b -> EitherT a m b
liftE x = MkEitherT $ pure x

verify_certificate_chain : HasIO io => Nat -> List Certificate -> List Certificate -> Certificate -> EitherT String io ()
verify_certificate_chain depth trusted untrusted current = do
  -- Constructs a lazy list of ca's which have cross signed the current certificate
  -- Won't be used if the certificate has a valid issuer which is in the chain
  let alternate = map (True,) $ flatten $ do
    ext <- extract_extension AuthorityKeyIdentifier current
    let predicate = auth_key_id_predicate ext
    pure $ filter predicate $ Lazy.fromList trusted

  -- List of certificates which subject name matches the current certificate's issuser name
  let in_chain = filter (\(_,c) => c.subject == current.issuer) (map (False,) untrusted <+> map (True,) trusted)
  let all_candidates = fromList in_chain <+> alternate

  case all_candidates of
    [] => throwE $ "cannot find issuer for: " <+> show current
    all => Lazy.choice $ map (\(should_trust,next) => go should_trust next current) all
  where
    -- Verify the issuer certificate and the subject's signature
    go : Bool -> Certificate -> Certificate -> EitherT String io ()
    go should_trust next current =
      case should_trust of
        False => do
          check_branch_certificate depth next
          let Right () = verify_certificate_signature current next
          | Left err => throwE $ "certificate failed for subject: " <+> show current <+> ", issuer: " <+> show next <+> ", reason " <+> err
          verify_certificate_chain (S depth) trusted untrusted next
        True => do
          -- replace the self signed certificate with the one in the trusted certificate list
          -- this should works since they are the same
          -- this prevents an attacker modifying the content of the certificate chain, changing the
          -- root ca's certificate with their own, with the same subject name but different public key
          let Just next = find (\c => c.subject == next.subject) trusted
          | Nothing => throwE $ "root certificate not trusted: " <+> show next
          check_branch_certificate depth next
          let Right () = verify_certificate_signature current next
          | Left err => throwE $ "certificate failed for subject: " <+> show current <+> ", issuer: " <+> show next <+> ", reason " <+> err
          pure ()

||| Given a list of trusted certificate, hostname of the server, verify the certificate chain
||| and return a public key to be used to verify TLS handshake
export
certificate_check : List Certificate -> String -> CertificateCheck IO
certificate_check trusted hostname cert = runEitherT $ do
  let certificates = body <$> cert.certificates
  ok <- liftE $ the _ $ traverse parse_certificate certificates
  let identifer = to_identifier hostname
  let Just cert = find_certificate identifer ok
  | Nothing => throwE "cannot find certificate"
  check_leaf_certificate cert
  verify_certificate_chain Z trusted ok cert
  pure cert.cert_public_key

||| A CertificateCheck function that always trusts the certificate unless it's malformed
export
certificate_ignore_check : String -> CertificateCheck IO
certificate_ignore_check hostname cert = runEitherT $ do
  let certificates = body <$> cert.certificates
  ok <- liftE $ the _ $ traverse parse_certificate certificates
  let identifer = to_identifier hostname
  let Just cert = find_certificate identifer ok
  | Nothing => throwE "cannot find certificate"
  pure cert.cert_public_key