CSV to vCard (.vcf) converter

csv2vcf.hs

#!/usr/bin/env stack
-- stack script --resolver lts-18.10 --package "cassava text vector bytestring regex-compat uuid classy-prelude containers"

-- Download Addresses from Xentral into CSV file from
-- https://xxx.xentral.biz/index.php?module=exportvorlage&action=edit&id=yyy
-- Then run:
-- cd /tmp && grep -vE ',"1",[^,]*,$' ~/Downloads/export.csv | csv2vcf.hs

-- Exportvorlage muss diese Felder in dieser Reihenfloge exportieren:
-- useredittimestamp; ansprechpartner; name; firma; mobil; telefon; email; telefax; id; geloescht;
-- CSV muss ,-getrennt sein, "-gequoted sein und Spaltenüberschriften beinhalten.

{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}

import ClassyPrelude
import Data.Csv (decodeWith, defaultDecodeOptions, DecodeOptions(..), HasHeader(..))
import Data.Char
import Data.Text (strip, replace)
import qualified Data.ByteString.Lazy as BS
import Text.Regex (subRegex, mkRegex)
import Data.UUID.V4 (nextRandom)
import qualified Data.Map as M

-- CSV delimiter and parsing options:

csvOptions = defaultDecodeOptions {decDelimiter = fromIntegral (ord ',')}

csvHasHeaderLine = True

-- Assign vCard fields:
-- https://de.wikipedia.org/wiki/VCard
csvRecordToVCard :: [Text] -> VCard
csvRecordToVCard record =
  VCard [("EMAIL", getField 6 record)
        ,("UID", getField 8 record)
        ,("ORG", fixText $ getField 2 record) -- comma is not allowed -> fixText
        ,("N", concat [fixText $ snd $ firstLast record, ";", fixText $ fst $ firstLast record])
        ,("FN", fullName record)
        -- ,("TEL;TYPE=home,voice", fixPhoneNumbers $ getField 4 record)
        ,("TEL;TYPE=cell,voice", fixPhoneNumbers $ getField 4 record)
        ,("TEL;TYPE=work,voice", fixPhoneNumbers $ getField 5 record)
        ,("TEL;TYPE=work,fax", fixPhoneNumbers $ getField 7 record)]
        -- sample phone number in vCard v4.0 format:
        -- TEL;TYPE=home,voice;VALUE=uri:tel:+49-221-1234567

main :: IO ()
main = do
  s <- BS.getContents
  let hasHeader = if csvHasHeaderLine then HasHeader else NoHeader
  let parseResult = decodeWith csvOptions hasHeader s :: Either String (Vector [Text])
  case parseResult of
    Left err -> putStrLn $ pack err
    Right csv -> do
     let csvFixed = map (map strip) $ toList csv
     let vcards = filter keepVCard $ map csvRecordToVCard csvFixed

     -- print everything to stdout
     mapM_ (putStrLn . tshow) vcards

     -- print each vCard to individual file with given name
     mapM_ (\card -> writeFileUtf8 (maybe "UID-MISSING.vcf" (++".vcf") $ getUID card) (tshow card)) vcards

     -- print each vCard to individual file
     -- mapM_ (printToFileUUIDFilename . tshow) vcards

firstLast :: [Text] -> (Text, Text)
firstLast [n, a, f]
  | n == "" = let as = words a in if length as > 1
                then (getField 0 as, unwords $ drop 1 as)
                else ("", a)
  | otherwise = let ns = words n in if length ns > 1
                then (getField 0 ns, unwords $ drop 1 ns)
                else ("", n)
firstLast _ = ("", "")

fullName :: [Text] -> Text
fullName xs = if f == "" && l == ""
   then c
   else fixText $ strip $ concat [f, " ", l, " (", c, ")"]
  where
    c = getField 2 xs
    (f,l) = firstLast xs

fixPhoneNumbers :: Text -> Text
fixPhoneNumbers = pack . flip (subRegex (mkRegex "[^0-9+-]")) "" . unpack

-- | Comma, semicolon, backslash and others must be escaped.
fixText :: Text -> Text
fixText = replace "," "\\," . replace ";" "\\;" . replace "\\" "\\\\"

getUID :: VCard -> Maybe String
getUID = fmap unpack . lookupField "UID"

keepVCard :: VCard -> Bool
keepVCard card = not $ and [empty "ORG", empty "FN", empty "EMAIL"]
  where
    empty :: Text -> Bool
    empty k = "" == fromMaybe "" (lookupField k card)

printToFileUUIDFilename :: Text -> IO ()
printToFileUUIDFilename text = do
  uuid <- nextRandom
  writeFileUtf8 (show uuid ++ ".vcf") text

newtype VCard = VCard
  { props :: [(Text, Text)]
  } deriving (Eq)

-- https://de.wikipedia.org/wiki/VCard
instance Show VCard where
  show (VCard xs) = ("BEGIN:VCARD\nVERSION:4.0\n" :: String)
                   ++ concatMap (\(x,y) -> unpack x ++ ":" ++ unpack y ++ "\n") (sort xs)
                   ++ ("END:VCARD\n" :: String)

lookupField :: Text -> VCard -> Maybe Text
lookupField key = M.lookup key . M.fromList . props

getField :: Int -> [Text] -> Text
getField i xs =
  case drop i xs of
    x : _ -> x
    _ -> ""