{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
module Hyrax.Abif.Read
( readAbif
, getAbif
, clear
, clearAbif
, getDebug
, getPString
, getCString
, getHeader
, getRoot
, getDirectories
, getDirectory
) where
import Protolude
import qualified Data.Text as Txt
import qualified Data.Text.Encoding as TxtE
import qualified Data.Binary as B
import qualified Data.Binary.Get as B
import qualified Data.ByteString.Lazy as BSL
import Control.Monad.Fail (fail)
import Hyrax.Abif
readAbif :: FilePath -> IO (Either Text Abif)
readAbif :: String -> IO (Either Text Abif)
readAbif String
path = ByteString -> Either Text Abif
getAbif forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BSL.readFile String
path
getAbif :: BSL.ByteString -> Either Text Abif
getAbif :: ByteString -> Either Text Abif
getAbif ByteString
bs = do
(Header
header, Directory
rootDir) <- case forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
B.runGetOrFail (ByteString -> Get (Header, Directory)
getRoot ByteString
bs) ByteString
bs of
Right (ByteString
_, Int64
_, (Header, Directory)
x) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Header, Directory)
x
Left (ByteString
_, Int64
_, String
e) -> forall a b. a -> Either a b
Left (Text
"Error reading root: " forall a. Semigroup a => a -> a -> a
<> String -> Text
Txt.pack String
e)
let dirBytes :: ByteString
dirBytes = Int64 -> ByteString -> ByteString
BSL.drop (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Directory -> Int
dDataOffset Directory
rootDir) ByteString
bs
[Directory]
ds <- case forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
B.runGetOrFail (ByteString -> [Directory] -> Int -> Get [Directory]
getDirectories ByteString
bs [] forall a b. (a -> b) -> a -> b
$ Directory -> Int
dElemNum Directory
rootDir) ByteString
dirBytes of
Right (ByteString
_, Int64
_, [Directory]
x) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Directory]
x
Left (ByteString
_, Int64
_, String
e) -> forall a b. a -> Either a b
Left (Text
"Error reading " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (Directory -> Int
dElemNum Directory
rootDir) forall a. Semigroup a => a -> a -> a
<> Text
" directories (at " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (Directory -> Int
dDataOffset Directory
rootDir) forall a. Semigroup a => a -> a -> a
<> Text
"): " forall a. Semigroup a => a -> a -> a
<> String -> Text
Txt.pack String
e)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Header -> Directory -> [Directory] -> Abif
Abif Header
header Directory
rootDir [Directory]
ds
clearAbif :: Abif -> Abif
clearAbif :: Abif -> Abif
clearAbif Abif
a = Abif
a { aRootDir :: Directory
aRootDir = Directory -> Directory
clear forall a b. (a -> b) -> a -> b
$ Abif -> Directory
aRootDir Abif
a
, aDirs :: [Directory]
aDirs = Directory -> Directory
clear forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abif -> [Directory]
aDirs Abif
a
}
clear :: Directory -> Directory
clear :: Directory -> Directory
clear Directory
d = Directory
d { dData :: ByteString
dData = ByteString
"" }
getDebug :: Directory -> Directory
getDebug :: Directory -> Directory
getDebug Directory
d =
let bsAtOffset :: ByteString
bsAtOffset = Directory -> ByteString
dData Directory
d in
case Directory -> ElemType
dElemType Directory
d of
ElemType
ElemPString ->
if Directory -> Int
dDataSize Directory
d forall a. Ord a => a -> a -> Bool
<= Int
4
then Directory
d { dDataDebug :: [Text]
dDataDebug = [ByteString -> Text
TxtE.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ByteString -> ByteString
BSL.drop Int64
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ByteString -> ByteString
BSL.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Directory -> Int
dDataSize Directory
d) forall a b. (a -> b) -> a -> b
$ Directory -> ByteString
dData Directory
d] }
else Directory
d { dDataDebug :: [Text]
dDataDebug = [forall a. Get a -> ByteString -> a
B.runGet (forall {a}. Get a -> Get a
lbl Get Text
getPString) ByteString
bsAtOffset] }
ElemType
ElemCString ->
if Directory -> Int
dDataSize Directory
d forall a. Ord a => a -> a -> Bool
<= Int
4
then Directory
d { dDataDebug :: [Text]
dDataDebug = [ByteString -> Text
TxtE.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ByteString -> ByteString
BSL.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Directory -> Int
dDataSize Directory
d forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ Directory -> ByteString
dData Directory
d] }
else Directory
d { dDataDebug :: [Text]
dDataDebug = [forall a. Get a -> ByteString -> a
B.runGet (forall {a}. Get a -> Get a
lbl forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Get Text
getCString forall a b. (a -> b) -> a -> b
$ Directory -> Int
dDataSize Directory
d) ByteString
bsAtOffset] }
ElemType
y ->
if Directory -> Int
dElemNum Directory
d forall a. Eq a => a -> a -> Bool
== Int
1
then
case ElemType
y of
ElemType
ElemDate ->
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Get a -> ByteString -> a
B.runGet (Directory -> ByteString
dData Directory
d) forall a b. (a -> b) -> a -> b
$ forall {a}. Get a -> Get a
lbl forall a b. (a -> b) -> a -> b
$ do
Int16
yy <- Get Int16
B.getInt16be
Int8
mt <- Get Int8
B.getInt8
Int8
dt <- Get Int8
B.getInt8
forall (f :: * -> *) a. Applicative f => a -> f a
pure Directory
d { dDataDebug :: [Text]
dDataDebug = [forall a b. (Show a, StringConv String b) => a -> b
show Int16
yy forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int8
mt forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int8
dt]}
ElemType
ElemTime ->
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Get a -> ByteString -> a
B.runGet (Directory -> ByteString
dData Directory
d) forall a b. (a -> b) -> a -> b
$ forall {a}. Get a -> Get a
lbl forall a b. (a -> b) -> a -> b
$ do
Int8
hr <- Get Int8
B.getInt8
Int8
mn <- Get Int8
B.getInt8
Int8
sc <- Get Int8
B.getInt8
Int8
ss <- Get Int8
B.getInt8
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Directory
d { dDataDebug :: [Text]
dDataDebug = [forall a b. (Show a, StringConv String b) => a -> b
show Int8
hr forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int8
mn forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int8
sc forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int8
ss] }
ElemType
ElemLong ->
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Get a -> ByteString -> a
B.runGet (Directory -> ByteString
dData Directory
d) forall a b. (a -> b) -> a -> b
$ forall {a}. Get a -> Get a
lbl forall a b. (a -> b) -> a -> b
$ do
Int32
x <- Get Int32
B.getInt32be
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Directory
d { dDataDebug :: [Text]
dDataDebug = [forall a b. (Show a, StringConv String b) => a -> b
show Int32
x] }
ElemType
ElemShort ->
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Get a -> ByteString -> a
B.runGet (Directory -> ByteString
dData Directory
d) forall a b. (a -> b) -> a -> b
$ forall {a}. Get a -> Get a
lbl forall a b. (a -> b) -> a -> b
$ do
Int16
x <- Get Int16
B.getInt16be
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Directory
d { dDataDebug :: [Text]
dDataDebug = [forall a b. (Show a, StringConv String b) => a -> b
show Int16
x] }
ElemType
ElemFloat ->
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Get a -> ByteString -> a
B.runGet (Directory -> ByteString
dData Directory
d) forall a b. (a -> b) -> a -> b
$ forall {a}. Get a -> Get a
lbl forall a b. (a -> b) -> a -> b
$ do
Float
x <- Get Float
B.getFloatbe
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Directory
d { dDataDebug :: [Text]
dDataDebug = [forall a b. (Show a, StringConv String b) => a -> b
show Float
x] }
ElemType
ElemWord ->
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Get a -> ByteString -> a
B.runGet (Directory -> ByteString
dData Directory
d) forall a b. (a -> b) -> a -> b
$ forall {a}. Get a -> Get a
lbl forall a b. (a -> b) -> a -> b
$ do
Int8
x <- Get Int8
B.getInt8
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Directory
d { dDataDebug :: [Text]
dDataDebug = [forall a b. (Show a, StringConv String b) => a -> b
show Int8
x] }
ElemType
ElemChar ->
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Get a -> ByteString -> a
B.runGet (Directory -> ByteString
dData Directory
d) forall a b. (a -> b) -> a -> b
$ forall {a}. Get a -> Get a
lbl forall a b. (a -> b) -> a -> b
$ do
Word8
x <- Get Word8
B.getWord8
let c :: ByteString
c = [Word8] -> ByteString
BSL.pack [Word8
x]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Directory
d { dDataDebug :: [Text]
dDataDebug = [ByteString -> Text
TxtE.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict forall a b. (a -> b) -> a -> b
$ ByteString
c] }
ElemType
_ -> Directory
d
else
case ElemType
y of
ElemType
ElemChar ->
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Get a -> ByteString -> a
B.runGet (Directory -> ByteString
dData Directory
d) forall a b. (a -> b) -> a -> b
$ forall {a}. Get a -> Get a
lbl forall a b. (a -> b) -> a -> b
$ do
[Word8]
cs <- forall n. Get n -> Get [n]
readArray Get Word8
B.getWord8
case Directory -> Text
dTagName Directory
d of
Text
"PCON" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Directory
d { dDataDebug :: [Text]
dDataDebug = [forall a b. (Show a, StringConv String b) => a -> b
show [Word8]
cs] }
Text
_ -> do
let c :: ByteString
c = [Word8] -> ByteString
BSL.pack [Word8]
cs
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Directory
d { dDataDebug :: [Text]
dDataDebug = [ByteString -> Text
TxtE.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict forall a b. (a -> b) -> a -> b
$ ByteString
c] }
ElemType
_ -> Directory
d
where
lbl :: Get a -> Get a
lbl = forall a. String -> Get a -> Get a
B.label forall a b. (a -> b) -> a -> b
$ String
"Reading " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (Directory -> Text
dElemTypeDesc Directory
d) forall a. Semigroup a => a -> a -> a
<> String
" data size=" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (Directory -> Int
dDataSize Directory
d) forall a. Semigroup a => a -> a -> a
<> String
" dir entry=" forall a. Semigroup a => a -> a -> a
<> Text -> String
Txt.unpack (Directory -> Text
dTagName Directory
d) forall a. Semigroup a => a -> a -> a
<> String
" cached data size=" forall a. Semigroup a => a -> a -> a
<> (forall a b. (Show a, StringConv String b) => a -> b
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BSL.length forall a b. (a -> b) -> a -> b
$ Directory -> ByteString
dData Directory
d) forall a. Semigroup a => a -> a -> a
<> String
". "
readArray :: B.Get n -> B.Get [n]
readArray :: forall n. Get n -> Get [n]
readArray Get n
getFn = do
Bool
e <- Get Bool
B.isEmpty
if Bool
e then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
n
c <- Get n
getFn
[n]
cs <- forall n. Get n -> Get [n]
readArray Get n
getFn
forall (f :: * -> *) a. Applicative f => a -> f a
pure (n
cforall a. a -> [a] -> [a]
:[n]
cs)
getPString :: B.Get Text
getPString :: Get Text
getPString = do
Int
sz <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
B.getInt8
ByteString -> Text
TxtE.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. String -> Get a -> Get a
B.label (String
"PString length=" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
sz forall a. Semigroup a => a -> a -> a
<> String
".") (Int -> Get ByteString
B.getByteString Int
sz)
getCString :: Int -> B.Get Text
getCString :: Int -> Get Text
getCString Int
sz =
ByteString -> Text
TxtE.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
B.getByteString (Int
sz forall a. Num a => a -> a -> a
- Int
1)
getHeader :: B.Get Header
=
Text -> Int -> Header
Header forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Text
TxtE.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
B.getByteString Int
4)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
B.getInt16be)
getRoot :: BSL.ByteString -> B.Get (Header, Directory)
getRoot :: ByteString -> Get (Header, Directory)
getRoot ByteString
bs = do
Header
h <- Get Header
getHeader
Directory
rd <- ByteString -> Get Directory
getDirectory ByteString
bs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Header
h, Directory
rd)
getDirectory :: BSL.ByteString -> B.Get Directory
getDirectory :: ByteString -> Get Directory
getDirectory ByteString
bs = do
Text
tagName <- ByteString -> Text
TxtE.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
B.getByteString Int
4
Int
tagNum <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
B.getInt32be
Int
typeCode <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
B.getInt16be
Int
elemSize <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
B.getInt16be
Int
elemNum <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
B.getInt32be
Int
dataSize <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
B.getInt32be
ByteString
offsetDataBytes <- forall {a}. Get a -> Get a
B.lookAhead forall a b. (a -> b) -> a -> b
$ Int64 -> Get ByteString
B.getLazyByteString Int64
4
Int
dataOffset <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
B.getInt32be
ByteString
dataBytes <- if Int
dataSize forall a. Ord a => a -> a -> Bool
<= Int
4
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
BSL.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dataSize) ByteString
offsetDataBytes
else case forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
B.runGetOrFail (Int64 -> Get ByteString
B.getLazyByteString forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dataSize) forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
BSL.drop (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dataOffset) ByteString
bs of
Right (ByteString
_, Int64
_, ByteString
x) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
x
Left (ByteString
_, Int64
_, String
e) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"error reading data (" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
dataSize forall a. Semigroup a => a -> a -> a
<> String
" bytes starting at " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
dataOffset forall a. Semigroup a => a -> a -> a
<> String
") for directory entry '" forall a. Semigroup a => a -> a -> a
<> Text -> String
Txt.unpack Text
tagName forall a. Semigroup a => a -> a -> a
<> String
"': " forall a. Semigroup a => a -> a -> a
<> String
e
let (ElemType
elemType, Text
elemCode) = Int -> (ElemType, Text)
describeElemType Int
typeCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure Directory { dTagName :: Text
dTagName = Text
tagName
, dTagNum :: Int
dTagNum = Int
tagNum
, dElemTypeCode :: Int
dElemTypeCode = Int
typeCode
, dElemTypeDesc :: Text
dElemTypeDesc = Text
elemCode
, dElemType :: ElemType
dElemType = ElemType
elemType
, dElemSize :: Int
dElemSize = Int
elemSize
, dElemNum :: Int
dElemNum = Int
elemNum
, dDataSize :: Int
dDataSize = Int
dataSize
, dDataOffset :: Int
dDataOffset = Int
dataOffset
, dData :: ByteString
dData = ByteString
dataBytes
, dDataDebug :: [Text]
dDataDebug = []
}
getDirectories :: BSL.ByteString -> [Directory] -> Int -> B.Get [Directory]
getDirectories :: ByteString -> [Directory] -> Int -> Get [Directory]
getDirectories ByteString
_ [Directory]
acc Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Directory]
acc
getDirectories ByteString
bs [Directory]
acc Int
more = do
Directory
d <- ByteString -> Get Directory
getDirectory ByteString
bs
Int -> Get ()
B.skip Int
4
ByteString -> [Directory] -> Int -> Get [Directory]
getDirectories ByteString
bs ([Directory]
acc forall a. Semigroup a => a -> a -> a
<> [Directory
d]) (Int
more forall a. Num a => a -> a -> a
- Int
1)