based/Main.hs

#!/usr/bin/env runhaskell
{-# LANGUAGE DeriveDataTypeable #-}

module Main where
import System.Console.CmdArgs 
import Control.Arrow
import Data.Text (pack, unpack, Text)
import Data.Bits
-- import Data.Char
import Text.Read (readMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
-- import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Encoding (decodeUtf8With, decodeUtf8, encodeUtf8)
import Data.Maybe (fromJust, fromMaybe)
import Data.Text.Encoding.Error (lenientDecode)
import TextShow (toText)
import Text.XML.HXT.DOM.Util (hexStringToInt, intToHexString, decimalStringToInt)
import TextShow.Data.Integral (showbBin, showbOct)
import Text.Ascii (fromBinDigit, fromOctDigit)
import Codec.CBOR.Magic (intToWord64)
import qualified Data.Either.Unwrap as U
import Data.Bytes.Text.Latin1 as Latin1
import qualified Codec.Binary.Base91 as B91
import qualified Codec.Binary.Base85 as B85
import qualified Codec.Binary.Base64 as B64
import qualified Data.ByteString.Base64 as B64L
import qualified Codec.Binary.Base64Url as B64U
import qualified Network.HTTP.Base as HB
import qualified Data.Word.Base62 as B62
import qualified Haskoin.Address.Base58 as B58
import qualified Codec.Binary.Base32 as B32
import qualified Codec.Binary.Base16 as B16
import qualified Codec.Binary.QuotedPrintable as QP
import qualified Codec.Binary.Uu as UU
import qualified Codec.Binary.Xx as XX
import qualified Codec.Binary.Yenc as Y
import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Text.Ascii as ASCII
import Data.Bytes.Get (getWord64host)
import Data.ByteString.UTF8 as BSU      -- from utf8-string
-- import Data.ByteString (singleton)
import GHC.Word (Word8)
import qualified Data.ByteString.Char8 as C
-- Regex imports
import Text.Regex.TDFA
import Data.Word (Word8)
import Data.Char (ord, chr, intToDigit, digitToInt)

data Based = Decode { 
              b91 :: Bool,
              b85 :: Bool,
              b64 :: Bool,
              b64url :: Bool,
              url :: Bool,
              b62 :: Bool,
              b58 :: Bool,
              b32 :: Bool,
              b16 :: Bool,
              b10 :: Bool,
              b8  :: Bool,
              b2  :: Bool,
              qp  :: Bool,
              uu  :: Bool,
              xx  :: Bool,
              yenc :: Bool,
              solve :: Bool
                    }
           | Encode { 
              b91 :: Bool,
              b85 :: Bool, 
              b64 :: Bool,
              b64url :: Bool,
              url :: Bool,
              b62 :: Bool,
              b58 :: Bool,
              b32 :: Bool,
              b16 :: Bool,
              b10 :: Bool,
              b8  :: Bool,
              b2  :: Bool,
              qp  :: Bool,
              uu  :: Bool,
              xx  :: Bool,
              yenc :: Bool
                     } 
             deriving(Show, Data, Typeable) 

-- helper functions

-- convertToByteString :: String -> Either String C.ByteString
-- convertToByteString str =
--    case BSU.fromString str of
--      Just bs -> Right bs
     -- Nothing -> Left "Failed to convert string to ByteString."

-- decodeFromBase91 :: String -> Either String C.ByteString
-- decodeFromBase91 decoded =
--    case B91.decode of
--       decoded | C.null decoded -> Left "Failed to decode from base91"
--               | otherwise -> Right decoded


encodeToBase64 :: C.ByteString -> Either String C.ByteString
encodeToBase64 bs =
   case B64.encode bs of
     encoded | C.null encoded -> Left "Failed to encode Base64.\n"
             | otherwise -> Right encoded

decodeFromBase64 :: C.ByteString -> Either String C.ByteString
decodeFromBase64 bs =
   case B64L.decodeLenient bs of 
     decoded | C.null decoded -> Left "Failed to decode from Base64.\n"
             | otherwise -> Right decoded
             -- | otherwise -> Right (BSU.toString decoded)
     -- Left err -> Left $ "Failed to decode from base64: " ++ err
     -- Right decoded -> Right decoded

binToInt :: [Int] -> Int
binToInt [] = 0
binToInt (x : xs) = x + 2 * binToInt xs

octToInt :: [Int] -> Int
octToInt [] = 0
octToInt (x : xs) = x + 8 * octToInt xs

-- base functions
-- without the show func, sequences like \n will not be shown as characters but will be executed as newline

dec91 :: String -> String
dec91 = T.unpack . T.decodeUtf8 . B91.decode

-- dec91 input =
--    maybe "Error decoding Base91.\n" T.unpack (T.decodeUtf8 (B91.decode input) 

-- dec91 :: String -> String
-- dec91 input =
--   case B91.decode input :: BSU.ByteString of
--     decoded -> C.unpack decoded

-- toWord8 :: String -> [Word8]
-- toWord8 = map (fromIntegral . fromEnum)

-- dec91 :: String -> String
-- dec91 input = 
--    map (chr . fromIntegral) (B91.decode input :: [Word8])

-- or
    -- case B91.decode input :: [Word8] of
        -- Right decoded -> map (toEnum . fromIntegral) decoded
        -- Left err -> "Error decoding Base91: " ++ err
    

enc91 :: String -> String
enc91 = B91.encode . BSU.fromString

-- dec85 = C.unpack . U.fromRight . B85.decode . BSU.fromString
dec85 :: String -> String
dec85 input =
    case B85.decode (BSU.fromString input) of
     Right decodedStr -> C.unpack decodedStr
     Left _ -> "Error decoding Base85.\n"

enc85 :: String -> String
enc85 = C.unpack . B85.encode . BSU.fromString

-- dec64 = C.unpack . B64L.decodeLenient . BSU.fromString
dec64 :: String -> String
dec64 input =
   case decodeFromBase64 (BSU.fromString input) of
     Right  byteString -> C.unpack byteString
     Left errMsg -> "Error: " ++ errMsg

-- enc64 = C.unpack . B64.encode . BSU.fromString
enc64 :: String -> String
enc64 input =
   case encodeToBase64 (BSU.fromString input) of
     Right byteString -> C.unpack byteString
     Left errMsg -> "Error: " ++ errMsg

dec64url :: String -> String
-- dec64url = C.unpack . U.fromRight . B64U.decode . BSU.fromString
dec64url input =
   case B64.decode (BSU.fromString input)  of
     Right decoded -> C.unpack decoded
     Left _ -> "Error decoding Base64 for URLs.\n"

enc64url :: String -> String
enc64url = C.unpack . B64U.encode . BSU.fromString

decurl :: String -> String
decurl = HB.urlDecode 

encurl :: String -> String
encurl = HB.urlEncode

dec62 :: String -> String
-- dec62 = T.unpack .  B62.text128 . fromJust . B62.decode128 . Bytes.fromAsciiString 
-- dec62 input =
--    case B62.decode128 (Bytes.fromAsciiString input) of
--      Just decoded -> (T.unpack (B62.text128 decoded))
--      -- Just decoded -> C.unpack decoded
--      Nothing -> "Error decoding Base62.\n"
   
-- dec62 = show . fromJust . B62.decode128 . (Bytes.fromByteString . BSU.fromString)
dec62 input =
   let decoded = B62.decode128 (Bytes.fromByteString (BSU.fromString input))
   in fromMaybe "Error decoding Base62.\n" (show <$> decoded)

-- dec62 input =
--    maybe "Error decoding Base62.\n" show (B62.decode128 (Bytes.fromByteString (BSU.fromString input)))

stringToInt :: String -> Maybe Integer
stringToInt = readMaybe

-- enc62 :: String -> String
-- enc62 = C.unpack . BSU.fromString. Latin1.toString . (Bytes.fromByteArray . ( B62.encode64 . (intToWord64 . decimalStringToInt)))
-- enc62 = T.unpack . T.decodeUtf8 . BSU.fromString . Latin1.toString . (Bytes.fromByteArray . ( B62.encode64 . (intToWord64  . decimalStringToInt)))
-- enc62 = T.unpack . T.decodeUtf8 . BSU.fromString . Latin1.toString . (Bytes.fromByteArray . (B62.encode128 . (fromIntegral  . ( BSU.fromString . fromJust StringToInt))))

-- working correct:
-- enc62 :: String -> String
-- enc62 = T.unpack . T.decodeUtf8 . BSU.fromString . Latin1.toString .  Bytes.fromByteArray . B62.encode64 . fromIntegral . fromJust . stringToInt

enc62 :: String -> String
enc62 input =
   let intValue = fromMaybe (error "Error: Unable to convert input string to integer") (stringToInt input)
       encoded = B62.encode64 (fromIntegral intValue)
       encodedText = T.decodeUtf8 (BSU.fromString (Latin1.toString (Bytes.fromByteArray encoded)))
    in T.unpack encodedText
-- enc62 :: Text -> Text
-- enc62 text = B62.text128 (fromIntegral (T.length text))

dec58 :: String -> String
-- dec58 = C.unpack . fromJust . B58.decodeBase58 . pack 
dec58 input = 
   maybe "Error decoding Base58.\n" C.unpack (B58.decodeBase58 (T.pack input))

enc58 :: String -> String
enc58 = T.unpack . B58.encodeBase58 . BSU.fromString

dec32 :: String -> String
-- dec32 = C.unpack . U.fromRight . B32.decode . BSU.fromString
dec32 input =
   case B32.decode (BSU.fromString input) of
     Right decoded -> C.unpack decoded
     Left _ -> "Error decoding Base32.\n"

enc32 :: String -> String
enc32 = C.unpack . B32.encode . BSU.fromString

dec16 :: String -> String
-- dec16 = C.unpack . U.fromRight . B16.decode . BSU.fromString
dec16 input =
   case B16.decode (BSU.fromString input) of
     Right decoded -> C.unpack decoded
     Left _ -> "Error decoding Base16.\n"

enc16 :: String -> String
enc16 = C.unpack . B16.encode . BSU.fromString

dec10 :: String -> String
dec10 = show . hexStringToInt 

enc10 :: String -> String
-- enc10 = C.unpack . BSU.fromString . intToHexString . decimalStringToInt -- Depending on what you want,  do enc10 = show . map ord
enc10 str = C.unpack $ C.pack $ Prelude.foldl (\acc char -> acc ++ show (ord char)) "" str

-- decode octal
octalToChar :: String -> Char
octalToChar str = chr $ Prelude.foldl (\acc c -> acc * 8 + read [c]) 0 str

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf n xs = Prelude.take n xs : chunksOf n (Prelude.drop n xs)

decodeOctal :: String -> String
decodeOctal = map octalToChar . words

-- decodeOctal :: String -> String
-- decodeOctal = map (octalToChar . padOctal) . words
  -- where
  --   -- Function to pad an octal number string with leading '0's if needed
  --   padOctal str
  --     | Prelude.length str == 1 && str /= "0" = "00" ++ str
  --     | Prelude.length str == 2 && str /= "0" = "0" ++ str
  --     | otherwise = str

-- Function to decode a string of octal numbers to characters
dec8 :: String -> String
dec8 = map octalToChar . chunksOf 3 . filter (/= ' ')

-- dec8 :: String -> String
-- dec8  = C.unpack . encodeUtf8 . toText . showbOct . hexStringToInt

-- newtype Octal = Octal Int
-- octalToString :: Octal -> String
-- octalToString (Octal n) = show n

-- dec8 =  map (chr . octalToDecimal) . chunksOf 3
--    where
--       octalToDecimal :: Octal -> Int
--       octalToDecimal (Octal n) = Prelude.foldl (\acc c -> acc * 8 + digitToInt c) O (show n)

--       chunksOf :: Int -> [a] -> [[a]]
--       chunksOf _ [] = []
--       chunksOf n xs = Prelude.take n xs : chunksOf n (Prelude.drop n xs)

-- enc8 :: String -> String
-- enc8  = C.unpack . BSU.fromString . intToHexString . octToInt . (reverse . (map fromJust . (map fromOctDigit)))
--


-- unicodeToOctal :: Char -> String
-- unicodeToOctal c
--     | ord c >= 0 && ord c <= 7 = ['0', intToDigit (ord c)]
--     | otherwise                = padTo3Bits $ decimalToOctal' (ord c)
--    where
--       decimalToOctal' 0 = ""
--       decimalToOctal' m = let (q, r) = m `divMod` 8 in intToDigit r : decimalToOctal' q

--       padTo3Bits :: String -> String
--       padTo3Bits bits
--         | Prelude.length bits < 3 = replicate (3 - Prelude.length bits) '0' ++ bits
--         | otherwise       = bits

-- enc8 :: String -> String
-- enc8 = unwords . map (concatMap unicodeToOctal . (:[]))

unicodeToOctal :: Char -> [String]
unicodeToOctal c = chunksOf 3 $ reverse $ decimalToOctal' (ord c)
  where
    decimalToOctal' 0 = "0"
    decimalToOctal' m = let (q, r) = m `divMod` 8 in intToDigit r : if q == 0 then "" else decimalToOctal' q

enc8 :: String -> String
enc8 = unwords . concatMap unicodeToOctal

-- unicodeToOctal :: Char -> String
-- unicodeToOctal c = reverse $ padTo3Bits $ decimalToOctal' (ord c)
--    where
--       decimalToOctal' 0 = "0"
--       decimalToOctal' m = let (q, r) = m `divMod` 8 in intToDigit r : decimalToOctal' q

--       padTo3Bits :: String -> String
--       padTo3Bits bits = replicate (3 - Prelude.length bits) '0' ++ bits

-- enc8 :: String -> String
-- enc8 = concatMap unicodeToOctal

dec2 :: String -> String
-- dec2  = C.unpack . encodeUtf8 . toText . showbBin . hexStringToInt
-- dec2  = TL.unpack . toLazyText . showbBin . hexStringToInt . enc16
dec2  = TL.unpack . toLazyText . showbBin . hexStringToInt


enc2 :: String -> String
-- enc2  = C.unpack . BSU.fromString . intToHexString . binToInt . (reverse . (map fromJust . (map fromBinDigit)))
-- enc2 input = C.unpack $ C.pack $ show $ Prelude.foldl (\acc char -> (acc `shiftL` 8) .|. fromIntegral (ord char)) BSU.fromString
enc2 input = concatMap (\c -> padTo7Bits (decimalToBinary (ord c))) input
   where
      decimalToBinary :: Int -> String
      decimalToBinary 0 = "0"
      decimalToBinary n = reverse $ decimalToBinary' n
         where
            decimalToBinary' 0 = "" 
            decimalToBinary' m = let (q, r) = m `divMod` 2 in (if r == 0 then '0' else '1') : decimalToBinary' q
      padTo7Bits :: String -> String
      padTo7Bits bits = replicate (7 - Prelude.length bits) '0' ++ bits


decqp :: String -> String
-- decqp = C.unpack . U.fromRight . QP.decode . BSU.fromString
decqp input =
   case QP.decode (BSU.fromString input) of
     Right decoded -> C.unpack decoded
     Left _ -> "Error decoding QP.\n"

encqp :: String -> String
encqp = C.unpack . QP.encode . BSU.fromString

decuu :: String -> String
-- decuu = C.unpack . U.fromRight . UU.decode . BSU.fromString
decuu input =
   case UU.decode (BSU.fromString input) of
     Right decoded -> C.unpack decoded
     Left _ -> "Error decoding UU.\n"

encuu :: String -> String
encuu = C.unpack . UU.encode . BSU.fromString

decxx :: String -> String
-- decxx = C.unpack . U.fromRight . XX.decode . BSU.fromString
decxx input =
   case XX.decode (BSU.fromString input) of
     Right decoded -> C.unpack decoded
     Left _ -> "Error decoding XX.\n"

encxx :: String -> String
encxx = C.unpack . XX.encode . BSU.fromString

decy :: String -> String
-- decy  = C.unpack . U.fromRight . Y.decode . BSU.fromString
decy input =
   case Y.decode (BSU.fromString input) of
     Right decoded -> C.unpack decoded
     Left _ -> "Error decoding Y.\n"


ency :: String -> String
ency  = C.unpack . Y.encode  . BSU.fromString

base91Regex = "^[!-~]*$"
base85Regex = "^[0-9A-Za-z!#$%&()*+,-;<=>?@^_`{|}~]+$"
-- base85Regex = "^[A-Za-u0-9!\"#$%&((*+,-./;:<=@[]\\`]*$"
base64Regex = "^([A-Za-z0-9+/]{4})*([A-Za-z0-9+/]{3}=|[A-Za-z0-9+/]{2}==)?$"
base58Regex = "^[1-9A-HJ-NP-Za-km-z]+$" -- incorrect
base32Regex = "^(?:[A-Z2-7]{8})*(?:[A-Z2-7]{2}={6}|[A-Z2-7]{4}={4}|[A-Z2-7]{5}={3}|[A-Z2-7]{7}=)?$"
base16Regex = "^[0-9A-FXx]*$"
base10Regex = "^[0-9]*$"
base8Regex = "^[0-7]*$"
base2Regex = "^[01]*$" 
urlRegex = "^[a-zA-Z0-9%]*$"

solveEnc :: String -> String
solveEnc input =
   let isBase91 = BSU.fromString input =~ base91Regex :: Bool
       isBase85 = BSU.fromString input =~ base85Regex :: Bool
       isBase64 = BSU.fromString input =~ base64Regex :: Bool
       isBase58 = BSU.fromString input =~ base58Regex :: Bool
       isBase32 = BSU.fromString input =~ base32Regex :: Bool
       isBase16 = BSU.fromString input =~ base16Regex :: Bool
       isBase10 = BSU.fromString input =~ base10Regex :: Bool
       isBase8  = BSU.fromString input =~ base8Regex  :: Bool
       isBase2  = BSU.fromString input =~ base2Regex  :: Bool
       isURL = BSU.fromString input =~ urlRegex :: Bool
       base91Result = if isBase91 then "\nTrying base91:\n" ++ dec91 input else ""
       base85Result = if isBase85 then "\nTrying base85:\n" ++ dec85 input else ""
       base64Result = if isBase64 then "\nTrying base64:\n" ++ dec64 input else ""
       base58Result = if isBase58 then "\nTrying base58:\n" ++ dec58 input else ""
       base32Result = if isBase64 then "\nTrying base32:\n" ++ dec32 input else ""
       base16Result = if isBase16 then "\nTrying base16:\n" ++ dec16 input else "" 
       base10Result = if isBase10 then "\nTrying base10:\n" ++ dec10 input else ""
       base2Result  = if isBase2  then "\nTrying base2:\n"  ++ dec2  input else ""
       base8Result  = if isBase8  then "\nTrying base8:\n"  ++ dec8  input else ""
       urlResult    = if isURL    then "\nTrying URL decode:\n" ++ decurl input else ""
       results = filter (not . null) [base91Result, base85Result, base64Result, base58Result, base32Result, base16Result, base10Result, base8Result, base2Result, urlResult]
    in 
      if null results
         then "Not able to solve the encoding.\n"
         else unlines results

   --
   -- | input =~ base64Regex = dec64 input
   -- | input =~ base32Regex = dec32 input
   -- | otherwise = "Cannot decode: " ++ input
   --
   -- if BSU.fromString input =~ base64Regex :: Bool
   --   then dec64 input
   --   else "Not Base64.\n"
   -- ++ if BSU.fromString input =~ base32Regex :: Bool
   --   then dec32 input
   --   else "Not able to solve the encoding.\n"
       
-- optionHandler :: EncodeOptions -> Text -> Text
optionHandler Decode{b91=True} = dec91
optionHandler Encode{b91=True} = enc91
optionHandler Decode{b85=True} = dec85
optionHandler Encode{b85=True} = enc85
optionHandler Decode{b64=True} = dec64
optionHandler Encode{b64=True} = enc64
optionHandler Decode{b64url=True} = dec64url
optionHandler Encode{b64url=True} = enc64url
optionHandler Decode{url=True} = decurl
optionHandler Encode{url=True} = encurl
optionHandler Decode{b62=True} = dec62
optionHandler Encode{b62=True} = enc62
optionHandler Decode{b58=True} = dec58
optionHandler Encode{b58=True} = enc58
optionHandler Decode{b32=True} = dec32
optionHandler Encode{b32=True} = enc32
optionHandler Decode{b16=True} = dec16
optionHandler Encode{b16=True} = enc16
optionHandler Decode{b10=True} = dec10
optionHandler Encode{b10=True} = enc10
optionHandler Decode{b8=True}  = dec8
optionHandler Encode{b8=True}  = enc8
optionHandler Decode{b2=True}  = dec2
optionHandler Encode{b2=True}  = enc2
optionHandler Decode{qp=True}  = decqp
optionHandler Encode{qp=True}  = encqp
optionHandler Encode{uu=True}  = encuu
optionHandler Decode{uu=True}  = decuu
optionHandler Decode{xx=True}  = decxx
optionHandler Encode{xx=True}  = encxx
optionHandler Decode{yenc=True}   = decy
optionHandler Encode{yenc=True}   = ency
optionHandler Decode{solve=True} = solveEnc

decodeMode :: Based
decodeMode = Decode {
            b91 = def &= help "decode base91",
            b85 = def &= help "decode base85",
            b64 = def &= help "decode base64",
            b64url = def &= help "decode base64Url",
            url = def &= help "decode URI",
            b62 = def &= help "decode base62",
            b58 = def &= help "decode base58",
            b32 = def &= help "decode base32",
            b16 = def &= help "decode base16",
            b10 = def &= help "decode decimal from hex",
            b8  = def &= help "decode octal from hex",
            b2  = def &= help "decode binary from hex",
            qp  = def &= help "decode quoted-printable",
            uu  = def &= help "decode uu",
            xx  = def &= help "decode xx",
            yenc = def &= help "decode yEncode",
            solve = def &= help "solve encoding"
        }  &= help "Decode chosen base" &=auto

encodeMode :: Based
encodeMode = Encode {
            b91 = def &= help "encode base91",
            b85 = def &= help "encode base85",
            b64 = def &= help "encode base64",
            b64url = def &= help "encode base64Url",
            url = def &= help "encode URI",
            b62 = def &= help "encode base62",
            b58 = def &= help "encode base58",
            b32 = def &= help "encode base32",
            b16 = def &= help "encode base16",
            b10 = def &= help "encode base10 to hex",
            b8  = def &= help "encode octal to hex", 
            b2  = def &= help "encode binary to hex",
            qp  = def &= help "encode quoted-printable",
            uu  = def &= help "encode uu",
            xx  = def &= help "encode xx",
            yenc = def &= help "encode yEncode"
       } &= help "Encode chosen base"

main :: IO()
main = cmdArgs (modes[decodeMode, encodeMode] &= help "Anybased, when Cyberchef simply doesn't cut it.\nTo see every parameter of every mode use --help=all" &= program "based" &= summary "based v0.4") >>= interact . optionHandler