qute

  1-- SPDX-FileCopyrightText: 2026 Sören Tempel <soeren+git@soeren-tempel.net>
  2--
  3-- SPDX-License-Identifier: GPL-3.0-only
  4
  5-- | This module provides a parser for the @ar(5)@ file format. The
  6-- implementation provided here is modeled after OpenBSD's
  7-- [@ar(5)@](https://man.openbsd.org/ar.5) man page. The format has never been
  8-- standartized thus, incompatibilities between different @ar(5)@ formats. See
  9-- the HISTORY section in the aforementioned OpenBSD man page for more
 10-- information. Most implementations are suffciently compatible when not using
 11-- file names with spaces in them.
 12--
 13-- See also <https://marc.info/?t=179121127700004&r=1&w=2>.
 14module Data.Archive
 15  ( Object (..),
 16    Data.Archive.parse,
 17    qbeArchive,
 18  )
 19where
 20
 21import Control.Applicative ((<|>))
 22import Control.Exception (throwIO)
 23import Control.Monad (replicateM, void)
 24import Data.Maybe (catMaybes)
 25import Language.QBE (Program, parse)
 26import Numeric (readOct)
 27import Text.ParserCombinators.Parsec
 28  ( ParseError,
 29    Parser,
 30    SourceName,
 31    anyChar,
 32    char,
 33    count,
 34    digit,
 35    eof,
 36    many,
 37    noneOf,
 38    octDigit,
 39    optionMaybe,
 40    parse,
 41    skipMany,
 42    string,
 43  )
 44
 45data Object
 46  = Object
 47  { oName :: String,
 48    oTime :: Int,
 49    oUser :: Int,
 50    oGroup :: Int,
 51    oMode :: Int,
 52    oSize :: Int,
 53    oData :: String
 54  }
 55  deriving (Show, Eq)
 56
 57magicString :: Parser ()
 58magicString = void $ string "!<arch>\n"
 59
 60headerTrailer :: Parser ()
 61headerTrailer = void $ string "`\n"
 62
 63lexme :: Parser a -> Parser a
 64lexme p = p <* skipMany (char ' ')
 65
 66upTo :: Int -> Parser a -> Parser [a]
 67upTo n p
 68  | n <= 0 = return []
 69  | otherwise = catMaybes <$> replicateM n (optionMaybe p)
 70
 71------------------------------------------------------------------------
 72
 73-- From OpenBSD's ar(5):
 74--
 75-- > Only the name field has any provision for overflow. If any file name
 76-- > is more than 16 characters in length or contains an embedded space,
 77-- > the string "#1/" followed by the ASCII length of the name is written
 78-- > in the name field.
 79--
 80objName :: Parser (Either Int String)
 81objName =
 82  Left <$> (string "#1/" >> read <$> upTo 13 digit)
 83    <|> Right <$> upTo 16 (noneOf " ")
 84
 85objTime :: Parser Int
 86objTime = read <$> upTo 12 digit
 87
 88objUser :: Parser Int
 89objUser = read <$> upTo 6 digit
 90
 91objGroup :: Parser Int
 92objGroup = objUser
 93
 94objMode :: Parser Int
 95objMode = getOct . readOct <$> upTo 8 octDigit
 96  where
 97    getOct [(num, "")] = num
 98    getOct _ = error "unreachable"
 99
100objSize :: Parser Int
101objSize = read <$> upTo 10 digit
102
103------------------------------------------------------------------------
104
105-- From OpenBSD's ar(5):
106--
107-- > Objects in the archive are always an even number of bytes long; files
108-- > which are an odd number of bytes long are padded with a newline (‘\n’)
109-- > character, although the size in the header does not reflect this.
110--
111skipPadding :: Int -> Parser ()
112skipPadding size
113  | odd size = void (char '\n')
114  | otherwise = pure ()
115
116object :: Parser Object
117object = do
118  name <- lexme objName
119  time <- lexme objTime
120  oUid <- lexme objUser
121  oGid <- lexme objGroup
122  mode <- lexme objMode
123  size <- lexme objSize
124
125  headerTrailer
126  (name', size') <-
127    -- Overflow handling for name, see the 'objName' comment above.
128    case name of
129      Left ns ->
130        if ns > size
131          then fail "name length exceeds object length"
132          else (,size - ns) <$> count ns anyChar
133      Right n -> pure (n, size)
134
135  body <- count size' anyChar <* skipPadding size'
136  pure $
137    Object
138      { oName = name',
139        oTime = time,
140        oUser = oUid,
141        oGroup = oGid,
142        oMode = mode,
143        oSize = size,
144        oData = body
145      }
146
147------------------------------------------------------------------------
148
149parse :: SourceName -> String -> Either ParseError [Object]
150parse =
151  Text.ParserCombinators.Parsec.parse
152    ((magicString >> many object) <* eof)
153
154qbeArchive :: FilePath -> IO [Program]
155qbeArchive fp = do
156  ar <- readFile fp
157  objs <- case Data.Archive.parse fp ar of
158    Right x -> pure x
159    Left err -> throwIO err
160  mapM (\o -> parseFile (oName o) (oData o)) objs
161  where
162    parseFile name body =
163      case Language.QBE.parse name body of
164        Right x -> pure x
165        Left err -> throwIO err