TimedText.hs

   1 -- This file is part of htalkat
   2 -- Copyright (C) 2021 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE OverloadedStrings #-}
  12
  13 module TimedText where
  14
  15 import qualified Data.Array                 as A
  16 import qualified Data.ByteString.Lazy       as BL
  17 import qualified Data.ByteString.Lazy.Char8 as BLC
  18 import qualified Data.Text.Encoding.Error   as T
  19 import qualified Data.Text.Lazy             as T
  20 import qualified Data.Text.Lazy.Encoding    as T
  21
  22 #if !(MIN_VERSION_base(4,11,0))
  23 import           Data.Semigroup
  24 #endif
  25
  26 type TimedText = [ Either Int Char ]
  27
  28 pauseMax :: Int
  29 pauseMax = 64 * 64 - 1
  30
  31 encodeTimedText :: TimedText -> BL.ByteString
  32 encodeTimedText = pad . BL.concat . (encode <$>)
  33     where
  34     encode (Left n) | n <= 0 = BL.empty
  35     encode (Left n) | n >= pauseMax = "~//"
  36     encode (Left n) | (a,b) <- n `divMod` 64 = "~" <> base64BC a <> base64BC b
  37         where
  38         base64BC = BLC.singleton . (base64Array A.!)
  39         base64Array = A.listArray (0,63) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  40     encode (Right '~') = "~~"
  41     encode (Right c) = T.encodeUtf8 $ T.singleton c
  42     pad b = b <> BL.pack (replicate (fromIntegral $ (- BL.length b) `mod` padLength) 0)
  43     padLength = 24
  44
  45 decodeTimedText :: BL.ByteString -> TimedText
  46 decodeTimedText = decode . T.unpack . T.decodeUtf8With T.lenientDecode. unpad
  47     where
  48     decode [] = []
  49     decode ('~':'~':s) = Right '~' : decode s
  50     decode ('~':a:b:s) | Just n <- decodePause a b = Left n : decode s
  51     decode ('~':s) = decode s  -- unparseable sequence
  52     decode (c:s) = Right c : decode s
  53
  54     decodePause a b
  55         | Just n <- fromIntegral <$> decodeBase64Char a
  56         , Just m <- fromIntegral <$> decodeBase64Char b
  57         = Just $ 64*n + m
  58     decodePause _ _ = Nothing
  59     decodeBase64Char :: Char -> Maybe Int
  60     decodeBase64Char a | n <- fromEnum a - fromEnum 'A', 0 <= n && n < 26 = Just n
  61     decodeBase64Char a | n <- fromEnum a - fromEnum 'a', 0 <= n && n < 26 = Just $ 26 + n
  62     decodeBase64Char a | n <- fromEnum a - fromEnum '0', 0 <= n && n < 10 = Just $ 52 + n
  63     decodeBase64Char '+' = Just 62
  64     decodeBase64Char '/' = Just 63
  65     decodeBase64Char _ = Nothing
  66     unpad = BL.filter (/= 0)